packages feed

aeson-warning-parser (empty) → 0.1.0

raw patch · 6 files changed

+353/−0 lines, 6 filesdep +aesondep +basedep +containerssetup-changed

Dependencies added: aeson, base, containers, generic-deriving, rio, rio-prettyprint, text, transformers, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `aeson-warning-parser`
+
+All notable changes to this project will be documented in this file.
+
+The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
+and this project adheres to the
+[Haskell Package Versioning Policy](https://pvp.haskell.org/).
+
+## 0.1.0 - 2023-07-08
+
+* Spin out module `Pantry.Internal.AesonExtended` from package `pantry-0.8.3`.
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License
+
+Copyright (c) 2015-2023, Stack contributors
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+   list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+   this list of conditions and the following disclaimer in the documentation
+   and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its
+   contributors may be used to endorse or promote products derived from
+   this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,4 @@+# aeson-warning-parser
+
+A Haskell library that provides a JSON parser that warns about unexpected fields
+in objects.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ aeson-warning-parser.cabal view
@@ -0,0 +1,46 @@+cabal-version: 1.12
++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           aeson-warning-parser+version:        0.1.0+synopsis:       Library providing JSON parser that warns about unexpected fields in objects.+description:    Please see the README on GitHub at <https://github.com/commercialhaskell/aeson-warning-parser#readme>+category:       JSON+homepage:       https://github.com/commercialhaskell/aeson-warning-parser#readme+bug-reports:    https://github.com/commercialhaskell/aeson-warning-parser/issues+author:         Michael Snoyman+maintainer:     Mike Pilgrem <public@pilgrem.com>+copyright:      2018-2023 FP Complete+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/commercialhaskell/aeson-warning-parser++library+  exposed-modules:+      Data.Aeson.WarningParser+  other-modules:+      Paths_aeson_warning_parser+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      aeson+    , base >=4.12 && <5+    , containers+    , generic-deriving+    , rio+    , rio-prettyprint+    , text+    , transformers+    , unordered-containers+  default-language: Haskell2010
+ src/Data/Aeson/WarningParser.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections     #-}
+
+module Data.Aeson.WarningParser
+  ( WarningParser
+  , JSONWarning (..)
+  , WithJSONWarnings (..)
+  , withObjectWarnings
+  , jsonSubWarnings
+  , jsonSubWarningsT
+  , jsonSubWarningsTT
+  , logJSONWarnings
+  , noJSONWarnings
+  , tellJSONField
+  , unWarningParser
+  , (.:)
+  , (.:?)
+  , (..:)
+  , (...:)
+  , (..:?)
+  , (...:?)
+  , (..!=)
+  ) where
+
+import           Control.Monad.Trans.Writer.Strict
+                   ( WriterT, mapWriterT, runWriterT, tell )
+import qualified Data.Aeson as A
+import           Data.Aeson.Types hiding ( (.:), (.:?) )
+import qualified Data.Set as Set
+import           Data.Text ( unpack )
+import qualified Data.Text as T
+import           Generics.Deriving.Monoid ( mappenddefault, memptydefault )
+import           RIO
+import           RIO.PrettyPrint.StylesUpdate ( StylesUpdate )
+
+#if MIN_VERSION_aeson(2, 0, 0)
+import qualified Data.Aeson.Key
+import qualified Data.Aeson.KeyMap as HashMap
+
+keyToText :: Data.Aeson.Key.Key -> Text
+keyToText = Data.Aeson.Key.toText
+
+textToKey :: Text -> Data.Aeson.Key.Key
+textToKey = Data.Aeson.Key.fromText
+#else
+import qualified Data.HashMap.Strict as HashMap
+
+keyToText :: Text -> Text
+keyToText = id
+
+textToKey :: Text -> Text
+textToKey = id
+#endif
+
+-- | Extends the @.:@ warning to include the field name that failed to parse.
+(.:) :: FromJSON a => Object -> Text -> Parser a
+(.:) o p = modifyFailure
+  (("failed to parse field '" <> unpack p <> "': ") <>)
+  (o A..: textToKey p)
+{-# INLINE (.:) #-}
+
+-- | Extends the @.:?@ warning to include the field name that failed to parse.
+(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
+(.:?) o p = modifyFailure
+  (("failed to parse field '" <> unpack p <> "': ") <>)
+  (o A..:? textToKey p)
+{-# INLINE (.:?) #-}
+
+-- | 'WarningParser' version of @.:@.
+(..:) ::
+     FromJSON a
+  => Object
+  -> Text
+  -> WarningParser a
+o ..: k = tellJSONField k >> lift (o .: k)
+
+-- | 'WarningParser' version of @.:?@.
+(..:?) ::
+     FromJSON a
+  => Object
+  -> Text
+  -> WarningParser (Maybe a)
+o ..:? k = tellJSONField k >> lift (o .:? k)
+
+-- | 'WarningParser' version of @.!=@.
+(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a
+wp ..!= d =
+  flip mapWriterT wp $
+  \p -> do
+    a <- fmap snd p
+    fmap (, a) (fmap fst p .!= d)
+
+presentCount :: Object -> [Text] -> Int
+presentCount o = length . filter (\x -> HashMap.member (textToKey x) o)
+
+-- | Synonym version of @..:@.
+(...:) :: FromJSON a => Object -> [Text] -> WarningParser a
+_ ...: [] = fail "failed to find an empty key"
+o ...: ss@(key:_) = apply
+ where
+  pc = presentCount o ss
+  apply | pc == 0   = fail $
+                        "failed to parse field " ++
+                        show key ++ ": " ++
+                        "keys " ++ show ss ++ " not present"
+        | pc >  1   = fail $
+                        "failed to parse field " ++
+                        show key ++ ": " ++
+                        "two or more synonym keys " ++
+                        show ss ++ " present"
+        | otherwise = asum $ map (o..:) ss
+
+-- | Synonym version of @..:?@.
+(...:?) :: FromJSON a => Object -> [Text] -> WarningParser (Maybe a)
+_ ...:? [] = fail "failed to find an empty key"
+o ...:? ss@(key:_) = apply
+ where
+  pc = presentCount o ss
+  apply | pc == 0   = pure Nothing
+        | pc >  1   = fail $
+                        "failed to parse field " ++
+                        show key ++ ": " ++
+                        "two or more synonym keys " ++
+                        show ss ++ " present"
+        | otherwise = asum $ map (o..:) ss
+
+-- | Tell the warning parser about an expected field, so it doesn't warn about
+-- it.
+tellJSONField :: Text -> WarningParser ()
+tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key})
+
+-- | 'WarningParser' version of 'withObject'.
+withObjectWarnings ::
+     String
+  -> (Object -> WarningParser a)
+  -> Value
+  -> Parser (WithJSONWarnings a)
+withObjectWarnings expected f =
+  withObject expected $
+  \obj -> do
+    (a,w) <- runWriterT (f obj)
+    let unrecognizedFields =
+          Set.toList
+            ( Set.difference
+                (Set.fromList (map keyToText (HashMap.keys obj)))
+                (wpmExpectedFields w)
+            )
+    pure
+      ( WithJSONWarnings a
+          ( wpmWarnings w ++
+            case unrecognizedFields of
+                [] -> []
+                _ -> [JSONUnrecognizedFields expected unrecognizedFields]
+          )
+      )
+
+-- | Convert a 'WarningParser' to a 'Parser'.
+unWarningParser :: WarningParser a -> Parser a
+unWarningParser wp = do
+  (a,_) <- runWriterT wp
+  pure a
+
+-- | Log JSON warnings.
+logJSONWarnings ::
+     (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m)
+  => FilePath
+  -> [JSONWarning]
+  -> m ()
+logJSONWarnings fp =
+  mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w))
+
+-- | Handle warnings in a sub-object.
+jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a
+jsonSubWarnings f = do
+  WithJSONWarnings result warnings <- f
+  tell
+    ( mempty
+        { wpmWarnings = warnings
+        }
+    )
+  pure result
+
+-- | Handle warnings in a @Traversable@ of sub-objects.
+jsonSubWarningsT ::
+     Traversable t
+  => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
+jsonSubWarningsT f =
+  mapM (jsonSubWarnings . pure) =<< f
+
+-- | Handle warnings in a @Maybe Traversable@ of sub-objects.
+jsonSubWarningsTT ::
+     (Traversable t, Traversable u)
+  => WarningParser (u (t (WithJSONWarnings a)))
+  -> WarningParser (u (t a))
+jsonSubWarningsTT f =
+  mapM (jsonSubWarningsT . pure) =<< f
+
+-- Parsed JSON value without any warnings.
+noJSONWarnings :: a -> WithJSONWarnings a
+noJSONWarnings v = WithJSONWarnings v []
+
+-- | A JSON parser that warns about unexpected fields in objects.
+type WarningParser a = WriterT WarningParserMonoid Parser a
+
+-- | Monoid used by 'WarningParser' to track expected fields and warnings.
+data WarningParserMonoid = WarningParserMonoid
+  { wpmExpectedFields :: !(Set Text)
+  , wpmWarnings :: [JSONWarning]
+  } deriving Generic
+
+instance Semigroup WarningParserMonoid where
+  (<>) = mappenddefault
+
+instance Monoid WarningParserMonoid where
+  mempty = memptydefault
+  mappend = (<>)
+
+instance IsString WarningParserMonoid where
+  fromString s = mempty { wpmWarnings = [fromString s] }
+
+-- Parsed JSON value with its warnings.
+data WithJSONWarnings a = WithJSONWarnings a [JSONWarning]
+  deriving (Eq, Generic, Show)
+
+instance Functor WithJSONWarnings where
+  fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w
+
+instance Monoid a => Semigroup (WithJSONWarnings a) where
+  (<>) = mappenddefault
+
+instance Monoid a => Monoid (WithJSONWarnings a) where
+  mempty = memptydefault
+  mappend = (<>)
+
+-- | Warning output from 'WarningParser'.
+data JSONWarning
+  = JSONUnrecognizedFields String [Text]
+  | JSONGeneralWarning !Text
+  deriving Eq
+
+instance Show JSONWarning where
+  show = T.unpack . utf8BuilderToText . display
+
+instance Display JSONWarning where
+  display (JSONUnrecognizedFields obj [field]) =
+    "Unrecognized field in " <> fromString obj <> ": " <> display field
+  display (JSONUnrecognizedFields obj fields) =
+       "Unrecognized fields in "
+    <> fromString obj
+    <> ": "
+    <> display (T.intercalate ", " fields)
+  display (JSONGeneralWarning t) = display t
+
+instance IsString JSONWarning where
+  fromString = JSONGeneralWarning . T.pack
+
+instance FromJSON (WithJSONWarnings StylesUpdate) where
+  parseJSON v = noJSONWarnings <$> parseJSON v