autodocodec-exact (empty) → 0.0.0.0
raw patch · 4 files changed
+669/−0 lines, 4 filesdep +aesondep +aeson-prettydep +autodocodec
Dependencies added: aeson, aeson-pretty, autodocodec, base, bytestring, containers, mtl, pretty-show, scientific, text, unordered-containers, vector
Files
- CHANGELOG.md +2/−0
- LICENSE +21/−0
- autodocodec-exact.cabal +46/−0
- src/Autodocodec/Exact.hs +600/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# Changelog+
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2025 Tom Sydney Kerckhove++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ autodocodec-exact.cabal view
@@ -0,0 +1,46 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.36.1.+--+-- see: https://github.com/sol/hpack++name: autodocodec-exact+version: 0.0.0.0+synopsis: Exact decoder for autodocodec+homepage: https://github.com/NorfairKing/autodocodec#readme+bug-reports: https://github.com/NorfairKing/autodocodec/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: 2025 Tom Sydney Kerckhove+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ LICENSE+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/NorfairKing/autodocodec++library+ exposed-modules:+ Autodocodec.Exact+ other-modules:+ Paths_autodocodec_exact+ hs-source-dirs:+ src+ build-depends:+ aeson+ , aeson-pretty+ , autodocodec+ , base >=4.7 && <5+ , bytestring+ , containers+ , mtl+ , pretty-show+ , scientific+ , text+ , unordered-containers+ , vector+ default-language: Haskell2010
+ src/Autodocodec/Exact.hs view
@@ -0,0 +1,600 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+-- Because of the Foldable import, instead of CPP.+{-# OPTIONS_GHC -Wno-unused-imports #-}++-- This module is for parsing JSON (or Yaml) values with:+--+-- 1. Nice error messages, and+-- 2. Warnings about unrecognised fields.+--+-- This should be better suited for parsing configuration values than+-- Autodocodec.Aeson.Decode, but it may be slower.+module Autodocodec.Exact+ ( -- * Decoding JSON Values+ parseExactJSONViaCodec,+ parseExactJSONVia,++ -- ** Decoding JSON Objects+ parseExactJSONObjectViaCodec,+ parseExactJSONObjectVia,+ --+ ExactParseError (..),+ prettyExactParseError,+ ExactParseWarning (..),+ prettyExactParseWarning,+ ExactParseContext (..),+ ExactParseContextPiece (..),+ prettyWrapInContext,+ prettyExactParseContextPiece,+ )+where++import qualified Autodocodec.Aeson.Compat as Compat+import Autodocodec.Class+import Autodocodec.Codec+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer+import Data.Aeson as JSON+import Data.Aeson.Encode.Pretty as JSON+import Data.Aeson.Types as JSON+import qualified Data.ByteString.Lazy as LB+import Data.Coerce (coerce)+import Data.Foldable (foldl')+import qualified Data.HashMap.Strict as HashMap+import Data.List (intercalate)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import Data.Scientific as Scientific+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as Vector+import Text.Show.Pretty++-- | Implement 'JSON.parseExactJSON' via a type's codec.+parseExactJSONViaCodec :: (HasCodec a) => JSON.Value -> Either ExactParseError (a, [ExactParseWarning])+parseExactJSONViaCodec = parseExactJSONVia codec++-- | Implement 'JSON.parseExactJSON' via a given codec.+parseExactJSONVia :: ValueCodec void a -> JSON.Value -> Either ExactParseError (a, [ExactParseWarning])+parseExactJSONVia c v = runExactParser $ goV v c++parseExactJSONObjectViaCodec :: (HasObjectCodec a) => JSON.Object -> Either ExactParseError (a, [ExactParseWarning])+parseExactJSONObjectViaCodec = parseExactJSONObjectVia objectCodec++parseExactJSONObjectVia :: ObjectCodec void a -> JSON.Object -> Either ExactParseError (a, [ExactParseWarning])+parseExactJSONObjectVia c o = runExactParser $ withUnrecognisedKeys o (goO o c)++exactParseKey :: (FromJSONKey key) => Key -> ExactParser key+exactParseKey key =+ withContext (ExactParseContextPieceKeyParser key) $+ case fromJSONKey of+ FromJSONKeyCoerce -> pure $ coerce (Compat.fromKey key)+ FromJSONKeyText f -> pure $ f $ Compat.fromKey key+ FromJSONKeyTextParser f -> case JSON.parseEither f (Compat.fromKey key) of+ Left err -> exactError $ ExactParseErrorKeyParseError key err+ Right k -> pure k+ -- Is this correct?+ -- I don't understand what this option is for.+ FromJSONKeyValue f -> case JSON.parseEither f (JSON.String (Compat.fromKey key)) of+ Left err -> exactError $ ExactParseErrorKeyParseError key err+ Right k -> pure k++-- We use type-annotations here for readability of type information that is+-- gathered to case-matching on GADTs, they aren't strictly necessary.+goV :: JSON.Value -> Codec JSON.Value void a -> ExactParser a+goV value = \case+ NullCodec ->+ case value of+ JSON.Null -> return $ coerce ()+ _ -> exactError $ ExactParseErrorTypeMismatch "null" value+ BoolCodec mname ->+ withNamed mname $+ case value of+ JSON.Bool b -> return $ coerce b+ _ -> exactError $ ExactParseErrorTypeMismatch "a boolean" value+ StringCodec mname ->+ withNamed mname $+ case value of+ JSON.String s -> return $ coerce s+ _ -> exactError $ ExactParseErrorTypeMismatch "a string" value+ IntegerCodec mname bounds ->+ withNamed mname $+ case value of+ JSON.Number unsafeS ->+ let safetyBounds =+ Bounds+ { boundsLower = Just $ scientific (-1) 1024,+ boundsUpper = Just $ scientific 1 1024+ }+ in case checkBounds safetyBounds unsafeS of+ Left err -> exactError $ ExactParseErrorUnsafeNumber safetyBounds unsafeS err+ Right s ->+ case Scientific.floatingOrInteger s :: Either Double Integer of+ Left _ -> exactError $ ExactParseErrorTypeMismatch "an integer" value+ Right i -> case checkBounds bounds i of+ Left err -> exactError $ ExactParseErrorIntegerOutOfBounds bounds i err+ Right i' -> pure $ coerce i'+ _ -> exactError $ ExactParseErrorTypeMismatch "an integer" value+ NumberCodec mname bounds ->+ withNamed mname $+ case value of+ JSON.Number s ->+ case checkBounds bounds s of+ Left err -> exactError $ ExactParseErrorNumberOutOfBounds bounds s err+ Right s' -> pure $ coerce s'+ _ -> exactError $ ExactParseErrorTypeMismatch "a number" value+ ArrayOfCodec mname c ->+ withNamed mname $+ case value of+ JSON.Array array ->+ coerce+ <$> Vector.imapM+ ( \ix v ->+ withContext (ExactParseContextPieceArrayIndex ix) $+ goV v c+ )+ array+ _ -> exactError $ ExactParseErrorTypeMismatch "an array" value+ ObjectOfCodec mname oc ->+ withNamed mname $+ case value of+ JSON.Object o ->+ withUnrecognisedKeys o $+ goO o oc+ _ -> exactError $ ExactParseErrorTypeMismatch "an object" value+ HashMapCodec c ->+ case value of+ JSON.Object o ->+ coerce $+ withUnrecognisedKeys o $+ -- TODO warn on duplicate keys that may come from the key being+ -- parsed and then erased in HashMap.fromList.+ HashMap.fromList+ <$> mapM+ ( \(key, val) ->+ (,)+ <$> ( do+ recogniseKey key+ liftValueParser $ exactParseKey key+ )+ <*> withContext+ (ExactParseContextPieceKey key Nothing)+ (liftValueParser (goV val c))+ )+ (Compat.toList o)+ _ -> exactError $ ExactParseErrorTypeMismatch "an object" value+ MapCodec c ->+ case value of+ JSON.Object o ->+ coerce $+ withUnrecognisedKeys o $+ -- TODO warn on duplicate keys that may come from the key being+ -- parsed and then erased in Map.fromList.+ Map.fromList+ <$> mapM+ ( \(key, val) ->+ (,)+ <$> ( do+ recogniseKey key+ liftValueParser $ exactParseKey key+ )+ <*> withContext+ (ExactParseContextPieceKey key Nothing)+ (liftValueParser (goV val c))+ )+ (Compat.toList o)+ _ -> exactError $ ExactParseErrorTypeMismatch "an object" value+ ValueCodec ->+ pure $ coerce value+ EqCodec expected c -> do+ actual <- goV value c+ if expected == actual+ then pure (coerce actual)+ else exactError $ ExactParseErrorExactMatch (ppShow actual) (ppShow expected)+ BimapCodec f _ c -> do+ old <- goV value c+ case f old of+ Left err -> exactError $ ExactParseErrorBimapFailure err+ Right new -> pure new+ EitherCodec u c1 c2 -> do+ ctx <- ask+ let errOrFirst = runExactParserWithContext ctx $ Left <$> goV value c1+ errOrSecond = runExactParserWithContext ctx $ Right <$> goV value c2+ case u of+ PossiblyJointUnion -> coerce $ case errOrFirst of+ Right (l, ws) -> do+ tell ws :: ExactParser ()+ pure l+ Left lErr -> case errOrSecond of+ Right (r, ws) -> do+ tell ws+ pure r+ Left rErr ->+ exactError $ ExactParseErrorPossiblyJointBothFailed lErr rErr+ DisjointUnion -> coerce $+ case (errOrFirst, errOrSecond) of+ (Right (l, ws), Left _) -> do+ tell ws :: ExactParser ()+ pure l+ (Left _, Right (r, ws)) -> do+ tell ws+ pure r+ (Right _, Right _) -> exactError ExactParseErrorDisjointBothSucceeded+ (Left lErr, Left rErr) ->+ exactError $ ExactParseErrorDisjointBothFailed lErr rErr+ CommentCodec comment c ->+ withContext (ExactParseContextPieceComment comment) $+ goV value c+ ReferenceCodec ref c ->+ withContext (ExactParseContextPieceReference ref) $+ goV value c++goO :: JSON.Object -> Codec JSON.Object void a -> ExactObjectParser a+goO value = \case+ BimapCodec f _ c -> do+ old <- goO value c+ case f old of+ Left err -> exactError $ ExactParseErrorBimapFailure err+ Right new -> pure new+ EitherCodec u c1 c2 -> do+ ctx <- ask+ before <- get+ let errOrFirst = runExactObjectParserWithContext ctx before $ Left <$> goO value c1+ errOrSecond = runExactObjectParserWithContext ctx before $ Right <$> goO value c2+ case u of+ PossiblyJointUnion ->+ coerce $+ case errOrFirst of+ Right ((l, s), ws) -> do+ tell ws :: ExactObjectParser ()+ put s+ pure l+ Left lErr -> case errOrSecond of+ Right ((r, s), ws) -> do+ tell ws+ put s+ pure r+ Left rErr ->+ exactError $ ExactParseErrorPossiblyJointBothFailed lErr rErr+ DisjointUnion ->+ coerce $+ case (errOrFirst, errOrSecond) of+ (Right ((l, s), ws), Left _) -> do+ tell ws+ put s+ pure l+ (Left _, Right ((r, s), ws)) -> do+ tell ws :: ExactObjectParser ()+ put s+ pure r+ (Right _, Right _) -> exactError ExactParseErrorDisjointBothSucceeded+ (Left lErr, Left rErr) ->+ exactError $ ExactParseErrorDisjointBothFailed lErr rErr+ DiscriminatedUnionCodec discriminatorName _ hm -> do+ let key = Compat.toKey discriminatorName+ discriminator <- withContext (ExactParseContextPieceKey key Nothing) $ do+ case Compat.lookupKey key (value :: JSON.Object) of+ Nothing -> exactError $ ExactParseErrorMissingDiscriminator key value+ Just discriminatorValue -> do+ recogniseKey key+ case discriminatorValue of+ JSON.String discriminator -> pure discriminator+ _ -> exactError $ ExactParseErrorTypeMismatch "a string" discriminatorValue+ case HashMap.lookup discriminator hm of+ Nothing -> exactError $ ExactParseErrorUnknownDiscriminator discriminator value+ Just (codecName, c) ->+ withContext (ExactParseContextPieceDiscriminator discriminator codecName) $+ goO value c+ RequiredKeyCodec k c mDoc -> do+ let key = Compat.toKey k+ case Compat.lookupKey key value of+ Nothing -> exactError $ ExactParseErrorMissingRequiredKey key value+ Just v ->+ withContext (ExactParseContextPieceKey key mDoc) $ do+ recogniseKey key+ liftValueParser $+ goV v c+ OptionalKeyCodec k c mDoc ->+ coerce $ do+ let key = Compat.toKey k+ forM (Compat.lookupKey key value) $ \v ->+ withContext (ExactParseContextPieceKey key mDoc) $ do+ recogniseKey key+ liftValueParser $+ goV v c+ OptionalKeyWithDefaultCodec k c defaultValue mDoc ->+ coerce $ do+ let key = Compat.toKey k+ case Compat.lookupKey key value of+ Nothing -> pure defaultValue+ Just v ->+ withContext (ExactParseContextPieceKey key mDoc) $ do+ recogniseKey key+ liftValueParser $+ goV v c+ OptionalKeyWithOmittedDefaultCodec k c defaultValue mDoc ->+ coerce $ do+ let key = Compat.toKey k+ case Compat.lookupKey key value of+ Nothing -> pure defaultValue+ Just v -> do+ recogniseKey key+ withContext (ExactParseContextPieceKey key mDoc) $+ liftValueParser $+ goV v c+ PureCodec a ->+ pure a+ ApCodec ocf oca ->+ goO (value :: JSON.Object) ocf <*> goO (value :: JSON.Object) oca++newtype ExactObjectParser a = ExactObjectParser (StateT (Set Key) ExactParser a)+ deriving+ ( Functor,+ Applicative,+ Monad,+ MonadWriter [ExactParseWarning],+ MonadReader ExactParseContext,+ MonadState (Set Key),+ MonadError ExactParseError+ )++withUnrecognisedKeys :: JSON.Object -> ExactObjectParser a -> ExactParser a+withUnrecognisedKeys o (ExactObjectParser func) = do+ (result, leftovers) <- runStateT func (Compat.keysSet o)+ forM_ (NonEmpty.nonEmpty (Set.toList leftovers)) $ \ne ->+ exactWarning (ExactParseWarningUnrecognisedKeys ne)+ pure result++recogniseKey :: Key -> ExactObjectParser ()+recogniseKey = modify . Set.delete++liftValueParser :: ExactParser a -> ExactObjectParser a+liftValueParser func = ExactObjectParser $ lift func++runExactObjectParserWithContext :: ExactParseContext -> Set Key -> ExactObjectParser a -> Either ExactParseError ((a, Set Key), [ExactParseWarning])+runExactObjectParserWithContext ctx set (ExactObjectParser func) = do+ runExactParserWithContext ctx (runStateT func set)++newtype ExactParser a = ExactParser (WriterT [ExactParseWarning] (ReaderT ExactParseContext (Either ExactParseError)) a)+ deriving+ ( Functor,+ Applicative,+ Monad,+ MonadWriter [ExactParseWarning],+ MonadReader ExactParseContext,+ MonadError ExactParseError+ )++runExactParser :: ExactParser a -> Either ExactParseError (a, [ExactParseWarning])+runExactParser = runExactParserWithContext emptyExactParseContext++runExactParserWithContext :: ExactParseContext -> ExactParser a -> Either ExactParseError (a, [ExactParseWarning])+runExactParserWithContext ctx (ExactParser func) = runReaderT (runWriterT func) ctx++newtype ExactParseContext = ExactParseContext {unExactParseContext :: [ExactParseContextPiece]}+ deriving (Show, Eq, Semigroup, Monoid)++emptyExactParseContext :: ExactParseContext+emptyExactParseContext = ExactParseContext []++addContextPiece :: ExactParseContextPiece -> ExactParseContext -> ExactParseContext+addContextPiece piece (ExactParseContext pieces) =+ ExactParseContext (piece : pieces)++withContext ::+ (MonadReader ExactParseContext m) =>+ ExactParseContextPiece ->+ m a ->+ m a+withContext piece =+ local (addContextPiece piece)++withNamed :: Maybe Text -> ExactParser a -> ExactParser a+withNamed = \case+ Nothing -> id+ Just name -> withContext (ExactParseContextPieceNamed name)++prettyWrapInContext :: ExactParseContext -> [String] -> [String]+prettyWrapInContext (ExactParseContext context) message =+ foldl' go message context+ where+ go :: [String] -> ExactParseContextPiece -> [String]+ go ls piece =+ prettyExactParseContextPiece piece ++ ls++data ExactParseContextPiece+ = ExactParseContextPieceKey !Key !(Maybe Text)+ | ExactParseContextPieceArrayIndex !Int+ | ExactParseContextPieceComment !Text+ | ExactParseContextPieceReference !Text+ | ExactParseContextPieceDiscriminator !Text !Text+ | ExactParseContextPieceNamed !Text+ | ExactParseContextPieceKeyParser !Key+ deriving (Show, Eq)++prettyExactParseContextPiece :: ExactParseContextPiece -> [String]+prettyExactParseContextPiece = \case+ ExactParseContextPieceKey key mDoc ->+ case mDoc of+ Nothing -> [unwords ["in the value with key:", show @Key key]]+ Just doc ->+ unwords ["in the value with key:", show @Key key]+ : appendOnLine ["documented:"] (T.unpack doc)+ ExactParseContextPieceArrayIndex ix ->+ [unwords ["in the array at index", show @Int ix, "(so position", show @Int (ix + 1) <> ")"]]+ ExactParseContextPieceComment comment ->+ appendOnLine ["with comment:"] (T.unpack comment)+ ExactParseContextPieceReference ref ->+ appendOnLine ["as part of a schema referred to to as:"] (T.unpack ref)+ ExactParseContextPieceDiscriminator discriminator codecName ->+ [unwords ["with discriminator:", T.unpack discriminator, ", codec: ", T.unpack codecName]]+ ExactParseContextPieceNamed name ->+ appendOnLine ["as part of a schema named:"] (T.unpack name)+ ExactParseContextPieceKeyParser key ->+ appendOnLine ["while trying to parse this key:"] (show @Text (Compat.fromKey key))++exactError ::+ ( MonadReader ExactParseContext m,+ MonadError ExactParseError m+ ) =>+ ExactParseErrorMessage ->+ m a+exactError exactParseErrorMessage = do+ exactParseErrorContext <- ask+ throwError $ ExactParseError {..}++exactWarning :: ExactParseWarningMessage -> ExactParser ()+exactWarning exactParseWarningMessage = do+ exactParseWarningContext <- ask+ tell [ExactParseWarning {..}]++data ExactParseError = ExactParseError+ { exactParseErrorMessage :: ExactParseErrorMessage,+ exactParseErrorContext :: ExactParseContext+ }+ deriving (Show, Eq)++prettyExactParseError :: ExactParseError -> String+prettyExactParseError = unlines . ("Parse error:" :) . exactParseErrorLines++exactParseErrorLines :: ExactParseError -> [String]+exactParseErrorLines ExactParseError {..} =+ prettyWrapInContext exactParseErrorContext (prettyExactParseErrorMessage exactParseErrorMessage)++data ExactParseErrorMessage+ = ExactParseErrorTypeMismatch+ !String+ !JSON.Value+ | ExactParseErrorBimapFailure+ !String+ | ExactParseErrorExactMatch+ !String+ !String+ | ExactParseErrorPossiblyJointBothFailed !ExactParseError !ExactParseError+ | ExactParseErrorDisjointBothSucceeded+ | ExactParseErrorDisjointBothFailed !ExactParseError !ExactParseError+ | ExactParseErrorUnsafeNumber !(Bounds Scientific) !Scientific !String+ | ExactParseErrorNumberOutOfBounds !(Bounds Scientific) !Scientific !String+ | ExactParseErrorIntegerOutOfBounds !(Bounds Integer) !Integer !String+ | ExactParseErrorMissingRequiredKey !Key !JSON.Object+ | ExactParseErrorMissingDiscriminator !Key !JSON.Object+ | ExactParseErrorUnknownDiscriminator !Text !JSON.Object+ | ExactParseErrorKeyParseError !Key !String+ deriving (Show, Eq)++prettyExactParseErrorMessage :: ExactParseErrorMessage -> [String]+prettyExactParseErrorMessage = \case+ ExactParseErrorTypeMismatch expected value ->+ case showValue value of+ [line] -> [unwords ["Type mismatch: expected", expected <> ", but got:", line]]+ ls ->+ unwords ["Type mismatch: expected", expected, ", but got:"]+ : ls+ ExactParseErrorBimapFailure msg ->+ appendOnLine ["failed to parse:"] msg+ ExactParseErrorExactMatch actual expected -> case (lines actual, lines expected) of+ ([lineActual], [lineExpected]) ->+ [unwords ["Expected", lineExpected, "but got", lineActual]]+ ([lineActual], expectedLines) ->+ concat+ [ [unwords ["Expected"]],+ expectedLines,+ [unwords ["but got", lineActual]]+ ]+ (actualLines, [lineExpected]) ->+ concat+ [ [unwords ["Expected", lineExpected, "but got:"]],+ actualLines+ ]+ (actualLines, expectedLines) ->+ concat+ [ [unwords ["Expected:"]],+ expectedLines,+ [unwords ["but got:"]],+ actualLines+ ]+ ExactParseErrorPossiblyJointBothFailed l r ->+ concat+ [ ["Disjoint union: both branches failed:"],+ indent $ exactParseErrorLines l,+ ["and"],+ indent $ exactParseErrorLines r+ ]+ ExactParseErrorDisjointBothSucceeded ->+ ["Disjoint union: both branches succeeded, this is invalid."]+ ExactParseErrorDisjointBothFailed l r ->+ concat+ [ ["Disjoint union: both branches failed:"],+ indent $ exactParseErrorLines l,+ ["and"],+ indent $ exactParseErrorLines r+ ]+ ExactParseErrorUnsafeNumber _ s err ->+ [unwords ["Rejecting number that would cause excessive memory usage:", show @Scientific s], err]+ ExactParseErrorNumberOutOfBounds _ s err ->+ [unwords ["Number is out of bounds:", show @Scientific s], err]+ ExactParseErrorIntegerOutOfBounds _ i err ->+ [unwords ["Integer is out of bounds:", show @Integer i], err]+ ExactParseErrorMissingRequiredKey key o ->+ appendOnLine' ["Missing required key:", show @Key key ++ ", in object:"] (showObject o)+ ExactParseErrorMissingDiscriminator key o ->+ appendOnLine' ["Missing discriminator:", show @Key key ++ ", in object:"] (showObject o)+ ExactParseErrorUnknownDiscriminator discriminator o ->+ appendOnLine' ["Unknown discriminator value:", show @Text discriminator ++ ", in object:"] (showObject o)+ ExactParseErrorKeyParseError key err ->+ appendOnLine ["Error parsing key:", show @Key key ++ ":"] err+ where+ showValue :: JSON.Value -> [String]+ showValue = lines . T.unpack . TE.decodeUtf8 . LB.toStrict . JSON.encodePretty+ showObject :: JSON.Object -> [String]+ showObject = showValue . JSON.Object++ indent :: [String] -> [String]+ indent = map (" " ++)++appendOnLine :: [String] -> String -> [String]+appendOnLine ws str = appendOnLine' ws (lines str)++appendOnLine' :: [String] -> [String] -> [String]+appendOnLine' ws ls = case ls of+ [] -> [unwords ws]+ [line] -> [unwords $ ws ++ [line]]+ _ -> unwords ws : ls++data ExactParseWarning = ExactParseWarning+ { exactParseWarningContext :: ExactParseContext,+ exactParseWarningMessage :: ExactParseWarningMessage+ }+ deriving (Show, Eq)++prettyExactParseWarning :: ExactParseWarning -> String+prettyExactParseWarning = unlines . ("Parse warning:" :) . exactParseWarningLines++exactParseWarningLines :: ExactParseWarning -> [String]+exactParseWarningLines ExactParseWarning {..} =+ prettyWrapInContext exactParseWarningContext $+ prettyExactParseWarningMessage exactParseWarningMessage++data ExactParseWarningMessage = ExactParseWarningUnrecognisedKeys !(NonEmpty Key)+ deriving (Show, Eq)++prettyExactParseWarningMessage :: ExactParseWarningMessage -> [String]+prettyExactParseWarningMessage = \case+ ExactParseWarningUnrecognisedKeys keys -> case keys of+ key :| [] -> [unwords ["Unrecognised key:", show @Key key]]+ _ -> [unwords ["Unrecognised keys:", intercalate ", " (map (show @Key) (NonEmpty.toList keys))]]