autodocodec 0.2.3.0 → 0.5.0.0
raw patch · 9 files changed
Files
- CHANGELOG.md +67/−0
- autodocodec.cabal +4/−3
- src/Autodocodec.hs +13/−2
- src/Autodocodec/Aeson/Compat.hs +41/−13
- src/Autodocodec/Aeson/Decode.hs +56/−32
- src/Autodocodec/Aeson/Encode.hs +32/−34
- src/Autodocodec/Class.hs +63/−14
- src/Autodocodec/Codec.hs +316/−119
- src/Autodocodec/DerivingVia.hs +12/−0
CHANGELOG.md view
@@ -1,5 +1,72 @@ # Changelog +## [0.5.0.0] - 2025-06-20++This is technically a breaking change but it's unlikely that you'll need to+change any of your codecs.++### Changed++* Added the same `Coercible` trick to the `RequiredKeyCodec` constructor of a codec.++## [0.4.2.2] - 2024-09-01++### Added++* `boundedEnumCodec`++## [0.4.2.1] - 2024-08-21++### Added++* `optionalFieldOrNullWithDefault`+* `optionalFieldOrNullWithDefaultWith`+* `optionalFieldOrNullWithDefault'`+* `optionalFieldOrNullWithDefaultWith'`++## [0.4.2.0] - 2024-08-06++### Added++* `HasCodec` instances for `DList` and `DNonEmpty` from the `dlist` package.++## [0.4.1.0] - 2024-08-03++### Changed++* Moved the `ToJSON (Autodocodec a)` and `FromJSON (Autodocodec a)` instances so they are no longer orphans.++## [0.4.0.0] - 2024-07-26++This is technically a breaking change but it's unlikely that you'll need to+change any of your codecs.++### Changed++* Changed `NumberBounds` to `Bounds` and made both bounds optional.+* Added `IntegerCodec` as distinct from `NumberCodec` to represent integers+ effectively in documentation.++## [0.3.0.0] - 2024-07-19++### Added++* `HasCodec` instances for:+ * `Const`+ * `Dual`+ * `Semigroup.First`+ * `Semigroup.Last`+ * `Monoid.First`+ * `Monoid.Last`+++### Changed++* Refactored `Codec` so it's input and output parameters have a representative, not nominal role.+ This means one can now use `deriving newtype` with the `HasCodec` class.+* Fixed infinitely looping `Identity` instance+* Improve the documentation of `time`-related codecs to show `<string>` instead of `<any>`.+ ## [0.2.3.0] - 2024-06-23 ### Added
autodocodec.cabal view
@@ -1,17 +1,17 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.36.1. -- -- see: https://github.com/sol/hpack name: autodocodec-version: 0.2.3.0+version: 0.5.0.0 synopsis: Self-documenting encoder and decoder 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: 2021-2023 Tom Sydney Kerckhove+copyright: 2021-2024 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple@@ -42,6 +42,7 @@ , base >=4.7 && <5 , bytestring , containers+ , dlist , hashable , mtl , scientific
src/Autodocodec.hs view
@@ -48,6 +48,8 @@ optionalFieldWith, optionalFieldOrNullWith, optionalFieldWithDefaultWith,+ optionalFieldOrNullWithDefault,+ optionalFieldOrNullWithDefaultWith, optionalFieldWithOmittedDefault, optionalFieldWithOmittedDefaultWith, optionalFieldOrNullWithOmittedDefault,@@ -62,6 +64,8 @@ optionalFieldWith', optionalFieldOrNullWith', optionalFieldWithDefaultWith',+ optionalFieldOrNullWithDefault',+ optionalFieldOrNullWithDefaultWith', optionalFieldWithOmittedDefault', optionalFieldWithOmittedDefaultWith', optionalFieldOrNullWithOmittedDefault',@@ -74,14 +78,20 @@ boolCodec, textCodec, stringCodec,+ integerCodec,+ integerWithBoundsCodec, scientificCodec, scientificWithBoundsCodec, valueCodec, + -- *** Bounds+ Bounds (..),+ emptyBounds,+ boundedBounds,+ checkBounds,+ -- *** Integral codecs boundedIntegralCodec,- boundedIntegralNumberBounds,- integerCodec, unsafeUnboundedIntegerCodec, naturalCodec, unsafeUnboundedNaturalCodec,@@ -92,6 +102,7 @@ -- *** Enums shownBoundedEnumCodec,+ boundedEnumCodec, stringConstCodec, enumCodec,
src/Autodocodec/Aeson/Compat.hs view
@@ -5,12 +5,17 @@ #if MIN_VERSION_aeson(2,0,0) import Data.Aeson.Key (Key) import qualified Data.Aeson.Key as K+import Data.Aeson.KeyMap (KeyMap) import qualified Data.Aeson.KeyMap as KM #else import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Map as M #endif import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON+import Data.Set (Set)+import qualified Data.Set as S import Data.Text (Text) #if MIN_VERSION_aeson(2,0,0)@@ -30,60 +35,83 @@ #endif #if MIN_VERSION_aeson(2,0,0)-lookupKey :: Key -> KM.KeyMap v -> Maybe v+lookupKey :: Key -> KeyMap v -> Maybe v lookupKey = KM.lookup #else-lookupKey :: Text -> HM.HashMap Text v -> Maybe v+lookupKey :: Text -> HashMap Text v -> Maybe v lookupKey = HM.lookup #endif #if MIN_VERSION_aeson(2,0,0)-insert :: Key -> v -> KM.KeyMap v -> KM.KeyMap v+insert :: Key -> v -> KeyMap v -> KeyMap v insert = KM.insert #else-insert :: Text -> v -> HM.HashMap Text v -> HM.HashMap Text v+insert :: Text -> v -> HashMap Text v -> HashMap Text v insert = HM.insert #endif #if MIN_VERSION_aeson(2,0,0)-fromList :: [(Key, v)] -> KM.KeyMap v+fromList :: [(Key, v)] -> KeyMap v fromList = KM.fromList #else-fromList :: [(Text, v)] -> HM.HashMap Text v+fromList :: [(Text, v)] -> HashMap Text v fromList = HM.fromList #endif #if MIN_VERSION_aeson(2,0,0)-toList :: KM.KeyMap v -> [(Key, v)]+toList :: KeyMap v -> [(Key, v)] toList = KM.toList #else-toList ::HM.HashMap Text v -> [(Text, v)]+toList :: HashMap Text v -> [(Text, v)] toList = HM.toList #endif #if MIN_VERSION_aeson(2,0,0)-map :: (v1 -> v2) -> KM.KeyMap v1 -> KM.KeyMap v2+keysSet :: KeyMap v -> Set Key+keysSet = S.fromList . KM.keys+#else+keysSet :: HashHashMap Text v -> Set Key+keysSet = S.fromList . HS.toList . HM.keysSet+#endif++#if MIN_VERSION_aeson(2,0,0)+map :: (v1 -> v2) -> KeyMap v1 -> KeyMap v2 map = KM.map #else-map :: (v1 -> v2) -> HM.HashMap Text v1 -> HM.HashMap Text v2+map :: (v1 -> v2) -> HashMap Text v1 -> HashMap Text v2 map = HM.map #endif -liftToJSON :: (JSON.ToJSON1 f) => (a -> JSON.Value) -> ([a] -> JSON.Value) -> f a -> JSON.Value+liftToJSON ::+ (JSON.ToJSON1 f) =>+ (a -> JSON.Value) ->+ ([a] -> JSON.Value) ->+ f a ->+ JSON.Value #if MIN_VERSION_aeson(2,2,0) liftToJSON = JSON.liftToJSON (const False) #else liftToJSON = JSON.liftToJSON #endif -liftToEncoding :: (JSON.ToJSON1 f) => (a -> JSON.Encoding) -> ([a] -> JSON.Encoding) -> f a -> JSON.Encoding+liftToEncoding ::+ (JSON.ToJSON1 f) =>+ (a -> JSON.Encoding) ->+ ([a] -> JSON.Encoding) ->+ f a ->+ JSON.Encoding #if MIN_VERSION_aeson(2,2,0) liftToEncoding = JSON.liftToEncoding (const False) #else liftToEncoding = JSON.liftToEncoding #endif -liftParseJSON :: (JSON.FromJSON1 f) => (JSON.Value -> JSON.Parser a) -> (JSON.Value -> JSON.Parser [a]) -> JSON.Value -> JSON.Parser (f a)+liftParseJSON ::+ (JSON.FromJSON1 f) =>+ (JSON.Value -> JSON.Parser a) ->+ (JSON.Value -> JSON.Parser [a]) ->+ JSON.Value ->+ JSON.Parser (f a) #if MIN_VERSION_aeson(2,2,0) liftParseJSON = JSON.liftParseJSON Nothing #else
src/Autodocodec/Aeson/Decode.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# OPTIONS_GHC -fno-warn-partial-type-signatures -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Autodocodec.Aeson.Decode ( -- * Decoding JSON Values@@ -21,13 +21,15 @@ import qualified Autodocodec.Aeson.Compat as Compat import Autodocodec.Class import Autodocodec.Codec-import Autodocodec.DerivingVia import Control.Monad import Data.Aeson as JSON import Data.Aeson.Types as JSON+import Data.Coerce (coerce) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Map (Map)+import Data.Scientific as Scientific+import Data.Text (Text) import qualified Data.Text as T import Data.Vector (Vector) import qualified Data.Vector as V@@ -59,34 +61,59 @@ go :: context -> Codec context void a -> JSON.Parser a go value = \case NullCodec -> case (value :: JSON.Value) of- Null -> pure ()+ Null -> coerce (pure () :: JSON.Parser ()) _ -> typeMismatch "Null" value BoolCodec mname -> case mname of- Nothing -> parseJSON value- Just name -> withBool (T.unpack name) pure value+ Nothing -> coerce (parseJSON value :: JSON.Parser Bool)+ Just name -> coerce $ withBool (T.unpack name) pure value StringCodec mname -> case mname of- Nothing -> parseJSON value- Just name -> withText (T.unpack name) pure value- NumberCodec mname mBounds ->- ( \f -> case mname of- Nothing -> parseJSON value >>= f- Just name -> withScientific (T.unpack name) f value- )- ( \s -> case maybe Right checkNumberBounds mBounds s of- Left err -> fail err- Right s' -> pure s'+ Nothing -> coerce (parseJSON value :: JSON.Parser Text)+ Just name -> coerce $ withText (T.unpack name) pure value+ IntegerCodec mname bounds ->+ coerce $+ ( \f -> do+ let safetyBounds =+ Bounds+ { boundsLower = Just $ scientific (-1) 1024,+ boundsUpper = Just $ scientific 1 1024+ }+ checkSafetyBounds s =+ case checkBounds safetyBounds s of+ Left err -> fail err+ Right i' -> pure i'+ s <- case mname of+ Nothing -> parseJSON value >>= checkSafetyBounds+ Just name -> withScientific (T.unpack name) checkSafetyBounds value+ case Scientific.floatingOrInteger s :: Either Double Integer of+ Left _ -> fail $ "Number was not integer: " <> show s+ Right i -> f (i :: Integer) )+ ( \i -> case checkBounds bounds i of+ Left err -> fail err+ Right i' -> pure i'+ )+ NumberCodec mname bounds ->+ coerce $+ ( \f -> case mname of+ Nothing -> parseJSON value >>= f+ Just name -> withScientific (T.unpack name) f value+ )+ ( \s -> case checkBounds bounds s of+ Left err -> fail err+ Right s' -> pure s'+ ) ArrayOfCodec mname c -> ( \f -> case mname of Nothing -> parseJSON value >>= f Just name -> withArray (T.unpack name) f value ) ( \vector ->- forM- (V.indexed (vector :: Vector JSON.Value))- ( \(ix, v) ->- go v c JSON.<?> Index ix- )+ coerce $+ forM+ (V.indexed (vector :: Vector JSON.Value))+ ( \(ix, v) ->+ go v c JSON.<?> Index ix+ ) ) ObjectOfCodec mname c -> ( \f -> case mname of@@ -94,13 +121,13 @@ Just name -> withObject (T.unpack name) f value ) (\object_ -> (`go` c) (object_ :: JSON.Object))- HashMapCodec c -> Compat.liftParseJSON (`go` c) (`go` listCodec c) value :: JSON.Parser (HashMap _ _)- MapCodec c -> Compat.liftParseJSON (`go` c) (`go` listCodec c) value :: JSON.Parser (Map _ _)- ValueCodec -> pure (value :: JSON.Value)+ HashMapCodec c -> coerce (Compat.liftParseJSON (`go` c) (`go` listCodec c) value :: JSON.Parser (HashMap _ _))+ MapCodec c -> coerce (Compat.liftParseJSON (`go` c) (`go` listCodec c) value :: JSON.Parser (Map _ _))+ ValueCodec -> pure $ coerce value EqCodec expected c -> do actual <- go value c if expected == actual- then pure actual+ then pure (coerce actual) else fail $ unwords ["Expected", show expected, "but got", show actual] BimapCodec f _ c -> do old <- go value c@@ -110,15 +137,15 @@ EitherCodec u c1 c2 -> let leftParser v = Left <$> go v c1 rightParser v = Right <$> go v c2- in case u of+ in coerce $ case u of PossiblyJointUnion -> case parseEither leftParser value of Right l -> pure l Left err -> prependFailure (" Previous branch failure: " <> err <> "\n") (rightParser value) DisjointUnion -> case (parseEither leftParser value, parseEither rightParser value) of- (Left _, Right r) -> pure r (Right l, Left _) -> pure l+ (Left _, Right r) -> pure r (Right _, Right _) -> fail "Both branches of a disjoint union succeeded." (Left lErr, Left rErr) -> fail $@@ -137,20 +164,17 @@ ReferenceCodec _ c -> go value c RequiredKeyCodec k c _ -> do valueAtKey <- (value :: JSON.Object) JSON..: Compat.toKey k- go valueAtKey c JSON.<?> Key (Compat.toKey k)+ coerce $ go valueAtKey c JSON.<?> Key (Compat.toKey k) OptionalKeyCodec k c _ -> do let key = Compat.toKey k mValueAtKey = Compat.lookupKey key (value :: JSON.Object)- forM mValueAtKey $ \valueAtKey -> go (valueAtKey :: JSON.Value) c JSON.<?> Key key+ coerce $ forM mValueAtKey $ \valueAtKey -> go (valueAtKey :: JSON.Value) c JSON.<?> Key key OptionalKeyWithDefaultCodec k c defaultValue _ -> do let key = Compat.toKey k mValueAtKey = Compat.lookupKey key (value :: JSON.Object)- case mValueAtKey of+ coerce $ case mValueAtKey of Nothing -> pure defaultValue Just valueAtKey -> go (valueAtKey :: JSON.Value) c JSON.<?> Key key OptionalKeyWithOmittedDefaultCodec k c defaultValue mDoc -> go value $ OptionalKeyWithDefaultCodec k c defaultValue mDoc PureCodec a -> pure a ApCodec ocf oca -> go (value :: JSON.Object) ocf <*> go (value :: JSON.Object) oca--instance (HasCodec a) => JSON.FromJSON (Autodocodec a) where- parseJSON = fmap Autodocodec <$> parseJSONViaCodec
src/Autodocodec/Aeson/Encode.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# OPTIONS_GHC -fno-warn-partial-type-signatures -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Autodocodec.Aeson.Encode ( -- * Encoding JSON Values@@ -21,10 +21,10 @@ import qualified Autodocodec.Aeson.Compat as Compat import Autodocodec.Class import Autodocodec.Codec-import Autodocodec.DerivingVia import Data.Aeson (toJSON) import qualified Data.Aeson as JSON import qualified Data.Aeson.Encoding as JSON+import Data.Coerce (coerce) import Data.HashMap.Strict (HashMap) import Data.Map (Map) import Data.Scientific@@ -44,18 +44,18 @@ where go :: a -> ObjectCodec a void -> JSON.Object go a = \case- RequiredKeyCodec k c _ -> Compat.toKey k JSON..= toJSONVia c a- OptionalKeyCodec k c _ -> case (a :: Maybe _) of+ RequiredKeyCodec k c _ -> Compat.toKey k JSON..= toJSONVia c (coerce a)+ OptionalKeyCodec k c _ -> case (coerce a :: Maybe _) of Nothing -> mempty Just b -> Compat.toKey k JSON..= toJSONVia c b- OptionalKeyWithDefaultCodec k c _ mdoc -> go (Just a) (OptionalKeyCodec k c mdoc)+ OptionalKeyWithDefaultCodec k c _ mdoc -> go (Just a) (optionalKeyCodec k c mdoc) OptionalKeyWithOmittedDefaultCodec k c defaultValue mdoc ->- if a == defaultValue+ if coerce a == defaultValue then mempty- else go a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)+ else go a (optionalKeyWithDefaultCodec k (coerce c) (coerce defaultValue) mdoc) BimapCodec _ g c -> go (g a) c PureCodec _ -> mempty- EitherCodec _ c1 c2 -> case (a :: Either _ _) of+ EitherCodec _ c1 c2 -> case (coerce a :: Either _ _) of Left a1 -> go a1 c1 Right a2 -> go a2 c2 DiscriminatedUnionCodec propertyName mapping _ ->@@ -73,17 +73,18 @@ go :: a -> ValueCodec a void -> JSON.Value go a = \case NullCodec -> JSON.Null- BoolCodec _ -> toJSON (a :: Bool)- StringCodec _ -> toJSON (a :: Text)- NumberCodec _ _ -> toJSON (a :: Scientific)- ArrayOfCodec _ c -> toJSON (fmap (`go` c) (a :: Vector _))+ BoolCodec _ -> toJSON (coerce a :: Bool)+ StringCodec _ -> toJSON (coerce a :: Text)+ IntegerCodec _ _ -> toJSON (coerce a :: Integer)+ NumberCodec _ _ -> toJSON (coerce a :: Scientific)+ ArrayOfCodec _ c -> toJSON (fmap (`go` c) (coerce a :: Vector _)) ObjectOfCodec _ oc -> JSON.Object (toJSONObjectVia oc a)- HashMapCodec c -> Compat.liftToJSON (`go` c) (`go` listCodec c) (a :: HashMap _ _)- MapCodec c -> Compat.liftToJSON (`go` c) (`go` listCodec c) (a :: Map _ _)- ValueCodec -> (a :: JSON.Value)+ HashMapCodec c -> Compat.liftToJSON (`go` c) (`go` listCodec c) (coerce a :: HashMap _ _)+ MapCodec c -> Compat.liftToJSON (`go` c) (`go` listCodec c) (coerce a :: Map _ _)+ ValueCodec -> (coerce a :: JSON.Value) EqCodec value c -> go value c BimapCodec _ g c -> go (g a) c- EitherCodec _ c1 c2 -> case (a :: Either _ _) of+ EitherCodec _ c1 c2 -> case (coerce a :: Either _ _) of Left a1 -> go a1 c1 Right a2 -> go a2 c2 CommentCodec _ c -> go a c@@ -101,18 +102,18 @@ where goObject :: a -> ObjectCodec a void -> JSON.Series goObject a = \case- RequiredKeyCodec k c _ -> JSON.pair (Compat.toKey k) (toEncodingVia c a)- OptionalKeyCodec k c _ -> case (a :: Maybe _) of+ RequiredKeyCodec k c _ -> JSON.pair (Compat.toKey k) (toEncodingVia c (coerce a))+ OptionalKeyCodec k c _ -> case (coerce a :: Maybe _) of Nothing -> mempty :: JSON.Series Just b -> JSON.pair (Compat.toKey k) (toEncodingVia c b)- OptionalKeyWithDefaultCodec k c _ mdoc -> goObject (Just a) (OptionalKeyCodec k c mdoc)+ OptionalKeyWithDefaultCodec k c _ mdoc -> goObject (Just a) (optionalKeyCodec k c mdoc) OptionalKeyWithOmittedDefaultCodec k c defaultValue mdoc ->- if a == defaultValue+ if coerce a == defaultValue then mempty- else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)+ else goObject a (optionalKeyWithDefaultCodec k (coerce c) (coerce defaultValue) mdoc) PureCodec _ -> mempty :: JSON.Series BimapCodec _ g c -> goObject (g a) c- EitherCodec _ c1 c2 -> case (a :: Either _ _) of+ EitherCodec _ c1 c2 -> case (coerce a :: Either _ _) of Left a1 -> goObject a1 c1 Right a2 -> goObject a2 c2 DiscriminatedUnionCodec propertyName mapping _ ->@@ -128,22 +129,19 @@ go :: a -> ValueCodec a void -> JSON.Encoding go a = \case NullCodec -> JSON.null_- BoolCodec _ -> JSON.bool (a :: Bool)- StringCodec _ -> JSON.text (a :: Text)- NumberCodec _ _ -> JSON.scientific (a :: Scientific)- ArrayOfCodec _ c -> JSON.list (`go` c) (V.toList (a :: Vector _))+ BoolCodec _ -> JSON.bool (coerce a :: Bool)+ StringCodec _ -> JSON.text (coerce a :: Text)+ IntegerCodec _ _ -> JSON.scientific (fromInteger (coerce a :: Integer) :: Scientific)+ NumberCodec _ _ -> JSON.scientific (coerce a :: Scientific)+ ArrayOfCodec _ c -> JSON.list (`go` c) (V.toList (coerce a :: Vector _)) ObjectOfCodec _ oc -> JSON.pairs (toSeriesVia oc a)- HashMapCodec c -> Compat.liftToEncoding (`go` c) (`go` listCodec c) (a :: HashMap _ _)- MapCodec c -> Compat.liftToEncoding (`go` c) (`go` listCodec c) (a :: Map _ _)- ValueCodec -> JSON.value (a :: JSON.Value)+ HashMapCodec c -> Compat.liftToEncoding (`go` c) (`go` listCodec c) (coerce a :: HashMap _ _)+ MapCodec c -> Compat.liftToEncoding (`go` c) (`go` listCodec c) (coerce a :: Map _ _)+ ValueCodec -> JSON.value (coerce a :: JSON.Value) EqCodec value c -> go value c BimapCodec _ g c -> go (g a) c- EitherCodec _ c1 c2 -> case (a :: Either _ _) of+ EitherCodec _ c1 c2 -> case (coerce a :: Either _ _) of Left a1 -> go a1 c1 Right a2 -> go a2 c2 CommentCodec _ c -> go a c ReferenceCodec _ c -> go a c--instance (HasCodec a) => JSON.ToJSON (Autodocodec a) where- toJSON = toJSONViaCodec . unAutodocodec- toEncoding = toEncodingViaCodec . unAutodocodec
src/Autodocodec/Class.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} -- Because Eq is a superclass of Hashable in newer versions. {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -16,13 +19,21 @@ #if MIN_VERSION_aeson(2,0,0) import Data.Aeson.KeyMap (KeyMap) #endif+import Data.DList (DList)+import qualified Data.DList as DList+import Data.DList.DNonEmpty (DNonEmpty)+import qualified Data.DList.DNonEmpty as DNonEmpty+import Data.Functor.Const (Const (Const)) import Data.Functor.Identity import Data.HashMap.Strict (HashMap) import Data.Hashable (Hashable) import Data.Int import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map)+import qualified Data.Monoid as Monoid import Data.Scientific+import Data.Semigroup (Dual (Dual))+import qualified Data.Semigroup as Semigroup import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text)@@ -52,7 +63,7 @@ {-# MINIMAL codec #-} instance HasCodec Void where- codec = bimapCodec (\_ -> Left "Cannot decode a Void.") absurd ValueCodec+ codec = bimapCodec (\_ -> Left "Cannot decode a Void.") absurd valueCodec instance HasCodec Bool where codec = boolCodec@@ -117,11 +128,22 @@ codec = naturalCodec instance HasCodec JSON.Value where- codec = ValueCodec+ codec = valueCodec -instance (HasCodec a) => HasCodec (Identity a) where- codec = dimapCodec runIdentity Identity codec+deriving newtype instance (HasCodec a) => HasCodec (Identity a) +deriving newtype instance (HasCodec a) => HasCodec (Dual a)++deriving newtype instance (HasCodec a) => HasCodec (Semigroup.First a)++deriving newtype instance (HasCodec a) => HasCodec (Semigroup.Last a)++deriving newtype instance (HasCodec a) => HasCodec (Monoid.First a)++deriving newtype instance (HasCodec a) => HasCodec (Monoid.Last a)++deriving newtype instance (HasCodec a) => HasCodec (Const a b)+ instance (HasCodec a) => HasCodec (Maybe a) where codec = maybeCodec codec @@ -137,38 +159,43 @@ instance (HasCodec a) => HasCodec [a] where codec = listCodecForStringCompatibility +instance (HasCodec a) => HasCodec (DList a) where+ codec = dimapCodec DList.fromList DList.toList (codec :: JSONCodec [a])+ instance (HasCodec a) => HasCodec (NonEmpty a) where codec = nonEmptyCodec codec +instance (HasCodec a) => HasCodec (DNonEmpty a) where+ codec = dimapCodec DNonEmpty.fromNonEmpty DNonEmpty.toNonEmpty (codec :: JSONCodec (NonEmpty a))+ instance (Ord a, HasCodec a) => HasCodec (Set a) where codec = dimapCodec S.fromList S.toList codec instance (Ord k, FromJSONKey k, ToJSONKey k, HasCodec v) => HasCodec (Map k v) where- codec = MapCodec codec+ codec = mapCodec codec instance (Eq k, Hashable k, FromJSONKey k, ToJSONKey k, HasCodec v) => HasCodec (HashMap k v) where- codec = HashMapCodec codec+ codec = hashMapCodec codec #if MIN_VERSION_aeson(2,0,0) instance HasCodec v => HasCodec (KeyMap v) where codec = keyMapCodec codec #endif --- TODO make these instances better once aeson exposes its @Data.Aeson.Parser.Time@ or @Data.Attoparsec.Time@ modules. instance HasCodec Day where- codec = codecViaAeson "Day"+ codec = unsafeCodecViaAesonString "Day" instance HasCodec LocalTime where- codec = codecViaAeson "LocalTime"+ codec = unsafeCodecViaAesonString "LocalTime" instance HasCodec UTCTime where- codec = codecViaAeson "LocalTime"+ codec = unsafeCodecViaAesonString "UTCTime" instance HasCodec TimeOfDay where- codec = codecViaAeson "TimeOfDay"+ codec = unsafeCodecViaAesonString "TimeOfDay" instance HasCodec ZonedTime where- codec = codecViaAeson "ZonedTime"+ codec = unsafeCodecViaAesonString "ZonedTime" instance HasCodec NominalDiffTime where codec = dimapCodec realToFrac realToFrac (codec :: JSONCodec Scientific)@@ -262,6 +289,28 @@ ObjectCodec output output optionalFieldWithDefault' key defaultValue = optionalFieldWithDefaultWith' key codec defaultValue +-- | Like 'optionalFieldOrNull', but also interpret @null@ as the default value.+optionalFieldOrNullWithDefault ::+ (Eq output, HasCodec output) =>+ -- | Key+ Text ->+ -- | Default value+ output ->+ -- | Documentation+ Text ->+ ObjectCodec output output+optionalFieldOrNullWithDefault key defaultValue doc = optionalFieldOrNullWithDefaultWith key codec defaultValue doc++-- | Like 'optionalFieldOrNullWithDefault', but without documentation+optionalFieldOrNullWithDefault' ::+ (Eq output, HasCodec output) =>+ -- | Key+ Text ->+ -- | Default value+ output ->+ ObjectCodec output output+optionalFieldOrNullWithDefault' key defaultValue = optionalFieldOrNullWithDefaultWith' key codec defaultValue+ -- | An optional, or null, field -- -- During decoding, the field may be in the object. 'Nothing' will be parsed if it is not.@@ -276,7 +325,7 @@ -- | Documentation Text -> ObjectCodec (Maybe output) (Maybe output)-optionalFieldOrNull key doc = orNullHelper $ OptionalKeyCodec key (maybeCodec codec) (Just doc)+optionalFieldOrNull key doc = orNullHelper $ optionalKeyCodec key (maybeCodec codec) (Just doc) -- | Like 'optionalFieldOrNull', but without documentation optionalFieldOrNull' ::@@ -285,7 +334,7 @@ -- | Key Text -> ObjectCodec (Maybe output) (Maybe output)-optionalFieldOrNull' key = orNullHelper $ OptionalKeyCodec key (maybeCodec codec) Nothing+optionalFieldOrNull' key = orNullHelper $ optionalKeyCodec key (maybeCodec codec) Nothing optionalFieldWithOmittedDefault :: (Eq output, HasCodec output) =>
src/Autodocodec/Codec.hs view
@@ -1,9 +1,14 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RoleAnnotations #-}@@ -19,11 +24,8 @@ import Control.Monad.State import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) import qualified Data.Aeson as JSON-#if MIN_VERSION_aeson(2,0,0)-import Data.Aeson.KeyMap (KeyMap)-import qualified Data.Aeson.KeyMap as KM-#endif import qualified Data.Aeson.Types as JSON+import Data.Coerce (Coercible) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Hashable@@ -41,8 +43,13 @@ import Data.Vector (Vector) import qualified Data.Vector as V import Data.Void+import Data.Word import GHC.Generics (Generic) import Numeric.Natural+#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson.KeyMap (KeyMap)+import qualified Data.Aeson.KeyMap as KM+#endif -- $setup -- >>> import Autodocodec.Aeson (toJSONVia, toJSONViaCodec, toJSONObjectVia, toJSONObjectViaCodec, parseJSONVia, parseJSONViaCodec, parseJSONObjectVia, parseJSONObjectViaCodec)@@ -71,53 +78,76 @@ -- * The @input@ parameter is used for the type that is used during encoding of a value, so it's the @input@ to the codec. -- * The @output@ parameter is used for the type that is used during decoding of a value, so it's the @output@ of the codec. -- * Both parameters are unused during documentation.+type role Codec _ representational representational+ data Codec context input output where -- | Encode '()' to the @null@ value, and decode @null@ as '()'. NullCodec ::- ValueCodec () ()+ (Coercible a (), Coercible b ()) =>+ ValueCodec a b -- | Encode a 'Bool' to a @boolean@ value, and decode a @boolean@ value as a 'Bool'. BoolCodec ::+ (Coercible a Bool, Coercible b Bool) => -- | Name of the @bool@, for error messages and documentation. Maybe Text ->- JSONCodec Bool+ ValueCodec a b -- | Encode 'Text' to a @string@ value, and decode a @string@ value as a 'Text'. -- -- This is named after the primitive type "String" in json, not after the haskell type string. StringCodec ::+ (Coercible a Text, Coercible b Text) => -- | Name of the @string@, for error messages and documentation. Maybe Text ->- JSONCodec Text+ ValueCodec a b+ -- | Encode 'Integer' to a @number@ value, and decode a @number@ value as an 'Integer'.+ --+ -- The number has 'Bounds Integer'.+ -- These are only enforced at decoding time, not at encoding-time.+ --+ -- NOTE: Decoding 'Integer's is dangerous so decoding may fail for enormous numbers.+ -- API NOTE: This is separate from 'NumberCodec' so that we can produce+ -- more precise documentation about whether the numbers are integers.+ IntegerCodec ::+ (Coercible a Integer, Coercible b Integer) =>+ -- | Name of the @integer@, for error messages and documentation.+ Maybe Text ->+ -- | Bounds for the integer, these are checked and documented+ Bounds Integer ->+ ValueCodec a b -- | Encode 'Scientific' to a @number@ value, and decode a @number@ value as a 'Scientific'. --- -- The number has optional 'NumberBounds'.+ -- The number has 'Bounds Scientific'. -- These are only enforced at decoding time, not at encoding-time. -- -- NOTE: We use 'Scientific' here because that is what aeson uses. NumberCodec ::+ (Coercible a Scientific, Coercible b Scientific) => -- | Name of the @number@, for error messages and documentation. Maybe Text -> -- | Bounds for the number, these are checked and documented- Maybe NumberBounds ->- JSONCodec Scientific+ Bounds Scientific ->+ ValueCodec a b -- | Encode a 'HashMap', and decode any 'HashMap'. HashMapCodec ::- (Eq k, Hashable k, FromJSONKey k, ToJSONKey k) =>+ (Eq k, Hashable k, FromJSONKey k, ToJSONKey k, Coercible a (HashMap k v), Coercible b (HashMap k v)) => JSONCodec v ->- JSONCodec (HashMap k v)+ ValueCodec a b -- | Encode a 'Map', and decode any 'Map'. MapCodec ::- (Ord k, FromJSONKey k, ToJSONKey k) =>+ (Ord k, FromJSONKey k, ToJSONKey k, Coercible a (Map k v), Coercible b (Map k v)) => JSONCodec v ->- JSONCodec (Map k v)+ ValueCodec a b -- | Encode a 'JSON.Value', and decode any 'JSON.Value'. ValueCodec ::- JSONCodec JSON.Value+ (Coercible JSON.Value a, Coercible JSON.Value b) =>+ ValueCodec a b -- | Encode a 'Vector' of values as an @array@ value, and decode an @array@ value as a 'Vector' of values. ArrayOfCodec ::+ (Coercible a (Vector input), Coercible b (Vector output)) => -- | Name of the @array@, for error messages and documentation. Maybe Text -> ValueCodec input output ->- ValueCodec (Vector input) (Vector output)+ ValueCodec a b -- | Encode a value as a an @object@ value using the given 'ObjectCodec', and decode an @object@ value as a value using the given 'ObjectCodec'. ObjectOfCodec :: -- | Name of the @object@, for error messages and documentation.@@ -126,12 +156,12 @@ ValueCodec input output -- | Match a given value using its 'Eq' instance during decoding, and encode exactly that value during encoding. EqCodec ::- (Show value, Eq value) =>+ (Show value, Eq value, Coercible a value, Coercible b value) => -- | Value to match value -> -- | Codec for the value JSONCodec value ->- JSONCodec value+ ValueCodec a b -- | Map a codec in both directions. -- -- This is not strictly dimap, because the decoding function is allowed to fail,@@ -156,13 +186,14 @@ -- In particular, you should prefer using it for values rather than objects, -- because those docs are easier to generate. EitherCodec ::+ (Coercible a (Either input1 input2), Coercible b (Either output1 output2)) => -- | What type of union we encode and decode !Union -> -- | Codec for the 'Left' side Codec context input1 output1 -> -- | Codec for the 'Right' side Codec context input2 output2 ->- Codec context (Either input1 input2) (Either output1 output2)+ Codec context a b -- | Encode/decode a discriminated union of objects -- -- The type of object being encoded/decoded is discriminated by@@ -209,22 +240,25 @@ ~(ValueCodec input output) -> ValueCodec input output RequiredKeyCodec ::+ (Coercible a input, Coercible b output) => -- | Key Text -> -- | Codec for the value ValueCodec input output -> -- | Documentation Maybe Text ->- ObjectCodec input output+ ObjectCodec a b OptionalKeyCodec ::+ (Coercible a (Maybe input), Coercible b (Maybe output)) => -- | Key Text -> -- | Codec for the value ValueCodec input output -> -- | Documentation Maybe Text ->- ObjectCodec (Maybe input) (Maybe output)+ ObjectCodec a b OptionalKeyWithDefaultCodec ::+ (Coercible b value) => -- | Key Text -> -- | Codec for the value@@ -233,9 +267,9 @@ value -> -- | Documentation Maybe Text ->- ObjectCodec value value+ ObjectCodec value b OptionalKeyWithOmittedDefaultCodec ::- (Eq value) =>+ (Eq value, Coercible a value, Coercible b value) => -- | Key Text -> -- | Codec for the value@@ -244,7 +278,7 @@ value -> -- | Documentation Maybe Text ->- ObjectCodec value value+ ObjectCodec a b -- | To implement 'pure' from 'Applicative'. -- -- Pure is not available for non-object codecs because there is no 'mempty' for 'JSON.Value', which we would need during encoding.@@ -262,24 +296,69 @@ ObjectCodec input output -> ObjectCodec input newOutput -data NumberBounds = NumberBounds- { numberBoundsLower :: !Scientific,- numberBoundsUpper :: !Scientific+data Bounds a = Bounds+ { -- | Lower bound, inclusive+ boundsLower :: !(Maybe a),+ -- Upper bound, inclusive+ boundsUpper :: !(Maybe a) }- deriving (Show, Eq, Ord, Generic)+ deriving (Show, Eq, Ord, Generic, Functor) -instance Validity NumberBounds+instance (Validity a) => Validity (Bounds a) +emptyBounds :: Bounds a+emptyBounds = Bounds Nothing Nothing++boundedBounds :: (Bounded a) => Bounds a+boundedBounds =+ Bounds+ { boundsLower = Just minBound,+ boundsUpper = Just maxBound+ }+ -- | Check if a number falls within given 'NumberBounds'.-checkNumberBounds :: NumberBounds -> Scientific -> Either String Scientific-checkNumberBounds NumberBounds {..} s =- if numberBoundsLower <= s- then- if s <= numberBoundsUpper- then Right s- else Left $ unwords ["Number", show s, "is bigger than the upper bound", show numberBoundsUpper]- else Left $ unwords ["Number", show s, "is smaller than the lower bound", show numberBoundsUpper]+checkBounds :: (Show a, Ord a) => Bounds a -> a -> Either String a+checkBounds Bounds {..} s =+ case boundsLower of+ Just lo | s < lo -> Left $ unwords ["Number", show s, "is smaller than the lower bound", show lo]+ _ -> case boundsUpper of+ Just hi | s > hi -> Left $ unwords ["Number", show s, "is bigger than the upper bound", show hi]+ _ -> Right s +data IntegerBoundsSymbolic+ = BitUInt !Word8 -- w bit unsigned int+ | BitSInt !Word8 -- w bit signed int+ | OtherIntegerBounds !(Maybe IntegerSymbolic) !(Maybe IntegerSymbolic)++guessIntegerBoundsSymbolic :: Bounds Integer -> IntegerBoundsSymbolic+guessIntegerBoundsSymbolic Bounds {..} =+ case (guessIntegerSymbolic <$> boundsLower, guessIntegerSymbolic <$> boundsUpper) of+ (Just Zero, Just (PowerOf2MinusOne w)) -> BitUInt w+ (Just (MinusPowerOf2 w1), Just (PowerOf2MinusOne w2)) | w1 == w2 -> BitSInt (succ w1)+ (l, u) -> OtherIntegerBounds l u++data IntegerSymbolic+ = Zero+ | PowerOf2 !Word8 -- 2^w+ | PowerOf2MinusOne !Word8 -- 2^w -1+ | MinusPowerOf2 !Word8 -- - 2^w+ | MinusPowerOf2MinusOne !Word8 -- - (2^w -1)+ | OtherInteger !Integer++guessIntegerSymbolic :: Integer -> IntegerSymbolic+guessIntegerSymbolic i =+ let log2Rounded :: Word8+ log2Rounded = round (logBase 2 (fromInteger (abs i)) :: Double)+ guess :: Integer+ guess = 2 ^ log2Rounded+ in if+ | i == 0 -> Zero+ | guess == i -> PowerOf2 log2Rounded+ | (guess - 1) == i -> PowerOf2MinusOne log2Rounded+ | -guess == i -> MinusPowerOf2 log2Rounded+ | -(guess - 1) == i -> MinusPowerOf2MinusOne log2Rounded+ | otherwise -> OtherInteger i+ -- | What type of union the encoding uses data Union = -- | Not disjoint, see 'possiblyJointEitherCodec'.@@ -332,6 +411,7 @@ NullCodec -> pure $ showString "NullCodec" BoolCodec mName -> pure $ showParen (d > 10) $ showString "BoolCodec " . showsPrec 11 mName StringCodec mName -> pure $ showParen (d > 10) $ showString "StringCodec " . showsPrec 11 mName+ IntegerCodec mName mbs -> pure $ showParen (d > 10) $ showString "IntegerCodec " . showsPrec 11 mName . showString " " . showsPrec 11 mbs NumberCodec mName mbs -> pure $ showParen (d > 10) $ showString "NumberCodec " . showsPrec 11 mName . showString " " . showsPrec 11 mbs ArrayOfCodec mName c -> (\s -> showParen (d > 10) $ showString "ArrayOfCodec " . showsPrec 11 mName . showString " " . s) <$> go 11 c ObjectOfCodec mName oc -> (\s -> showParen (d > 10) $ showString "ObjectOfCodec " . showsPrec 11 mName . showString " " . s) <$> go 11 oc@@ -794,6 +874,22 @@ listCodec :: ValueCodec input output -> ValueCodec [input] [output] listCodec = dimapCodec V.toList V.fromList . vectorCodec +-- Some restricted constructors+optionalKeyCodec :: Text -> ValueCodec input output -> Maybe Text -> ObjectCodec (Maybe input) (Maybe output)+optionalKeyCodec = OptionalKeyCodec++optionalKeyWithDefaultCodec ::+ -- | Key+ Text ->+ -- | Codec for the value+ ValueCodec value value ->+ -- | Default value+ value ->+ -- | Documentation+ Maybe Text ->+ ObjectCodec value value+optionalKeyWithDefaultCodec = OptionalKeyWithDefaultCodec+ -- | Build a codec for nonempty lists of values from a codec for a single value. -- --@@ -967,6 +1063,43 @@ ObjectCodec output output optionalFieldWithDefaultWith' key c defaultValue = OptionalKeyWithDefaultCodec key c defaultValue Nothing +-- | Like 'optionalFieldWithDefaultWith', but also interpret @null@ as the+-- default value.+optionalFieldOrNullWithDefaultWith ::+ (Eq output) =>+ -- | Key+ Text ->+ -- | Codec for the value+ JSONCodec output ->+ -- | Default value+ output ->+ -- | Documentation+ Text ->+ ObjectCodec output output+optionalFieldOrNullWithDefaultWith key c defaultValue doc = dimapCodec f g $ optionalFieldWithDefaultWith key (maybeCodec c) (Just defaultValue) doc+ where+ f = \case+ Just v -> v+ Nothing -> defaultValue+ g v = if v == defaultValue then Nothing else Just v++-- | Like 'optionalFieldOrNullWithDefaultWith', but without documentation.+optionalFieldOrNullWithDefaultWith' ::+ (Eq output) =>+ -- | Key+ Text ->+ -- | Codec for the value+ JSONCodec output ->+ -- | Default value+ output ->+ ObjectCodec output output+optionalFieldOrNullWithDefaultWith' key c defaultValue = dimapCodec f g $ optionalFieldWithDefaultWith' key (maybeCodec c) (Just defaultValue)+ where+ f = \case+ Just v -> v+ Nothing -> defaultValue+ g v = if v == defaultValue then Nothing else Just v+ -- | An optional field with default value that can be omitted when encoding -- -- During decoding, the field may be in the object. The default value will be parsed otherwise.@@ -1249,14 +1382,67 @@ -- -- > scientificCodec = NumberCodec Nothing Nothing scientificCodec :: JSONCodec Scientific-scientificCodec = NumberCodec Nothing Nothing+scientificCodec = NumberCodec Nothing emptyBounds +-- | Codec for 'Integer' values+--+-- This codec does a bounds check for the range [-10^1024, 10^1024] it can safely parse very large numbers.+--+--+-- === Example usage+--+-- >>> toJSONVia integerCodec 5+-- Number 5.0+-- >>> toJSONVia integerCodec (-1000000000000)+-- Number (-1.0e12)+-- >>> JSON.parseMaybe (parseJSONVia integerCodec) (Number (-4.0))+-- Just (-4)+-- >>> JSON.parseMaybe (parseJSONVia integerCodec) (Number (scientific 1 100000000))+-- Nothing+--+--+-- ==== API Note+--+-- This is a forward-compatible version of 'IntegerCodec' without a name.+--+-- > scientificCodec = IntegerCodec Nothing Nothing+--+-- For a codec without this protection, see 'unsafeUnboundedIntegerCodec'.+integerCodec :: JSONCodec Integer+integerCodec = IntegerCodec Nothing emptyBounds++-- | A codec for 'Natural' values.+--+-- This codec does a bounds check for the range [0, 10^1024] it can safely parse very large numbers.+--+-- For a codec without this protection, see 'unsafeUnboundedNaturalCodec'.+--+-- === Example usage+--+-- >>> toJSONVia naturalCodec 5+-- Number 5.0+-- >>> toJSONVia naturalCodec (1000000000000)+-- Number 1.0e12+-- >>> JSON.parseMaybe (parseJSONVia naturalCodec) (Number 4.0)+-- Just 4+-- >>> JSON.parseMaybe (parseJSONVia naturalCodec) (Number (scientific 1 100000000))+-- Nothing+naturalCodec :: JSONCodec Natural+naturalCodec =+ dimapCodec fromIntegral fromIntegral $+ integerWithBoundsCodec+ ( Bounds+ { boundsLower = Just 0,+ boundsUpper = Nothing+ }+ )+ -- | Codec for 'Scientific' values with bounds -- -- -- === Example usage ----- >>> let c = scientificWithBoundsCodec NumberBounds {numberBoundsLower = 2, numberBoundsUpper = 4}+-- >>> let c = scientificWithBoundsCodec Bounds {boundsLower = Just 2, boundsUpper = Just 4} -- >>> toJSONVia c 3 -- Number 3.0 -- >>> toJSONVia c 5@@ -1283,10 +1469,33 @@ -- -- This is a forward-compatible version of 'NumberCodec' without a name. ----- > scientificWithBoundsCodec bounds = NumberCodec Nothing (Just bounds)-scientificWithBoundsCodec :: NumberBounds -> JSONCodec Scientific-scientificWithBoundsCodec bounds = NumberCodec Nothing (Just bounds)+-- > scientificWithBoundsCodec bounds = NumberCodec Nothing bounds+scientificWithBoundsCodec :: Bounds Scientific -> JSONCodec Scientific+scientificWithBoundsCodec bounds = NumberCodec Nothing bounds +-- | Codec for 'Integer' values with bounds+--+--+-- === Example usage+--+-- >>> let c = integerWithBoundsCodec Bounds {boundsLower = Just 2, boundsUpper = Just 4}+-- >>> toJSONVia c 3+-- Number 3.0+-- >>> toJSONVia c 5+-- Number 5.0+-- >>> JSON.parseMaybe (parseJSONVia c) (Number 3)+-- Just 3+-- >>> JSON.parseMaybe (parseJSONVia c) (Number 5)+-- Nothing+--+-- ==== API Note+--+-- This is a forward-compatible version of 'IntegerCodec' without a name.+--+-- > integerWithBoundsCodec bounds = IntegerCodec Nothing bounds+integerWithBoundsCodec :: Bounds Integer -> JSONCodec Integer+integerWithBoundsCodec bounds = IntegerCodec Nothing bounds+ -- | An object codec with a given name -- --@@ -1326,51 +1535,13 @@ -- Nothing boundedIntegralCodec :: forall i. (Integral i, Bounded i) => JSONCodec i boundedIntegralCodec =- bimapCodec go fromIntegral $ scientificWithBoundsCodec (boundedIntegralNumberBounds @i)- where- go s = case Scientific.toBoundedInteger s of- Nothing -> Left $ "Number did not fit into bounded integer: " <> show s- Just i -> Right i+ dimapCodec fromIntegral fromIntegral $ integerWithBoundsCodec (boundedIntegralBounds @i) -- | 'NumberBounds' for a bounded integral type. ----- You can call this using @TypeApplications@: @boundedIntegralNumberBounds @Word@-boundedIntegralNumberBounds :: forall i. (Integral i, Bounded i) => NumberBounds-boundedIntegralNumberBounds =- NumberBounds- { numberBoundsLower = fromIntegral (minBound :: i),- numberBoundsUpper = fromIntegral (maxBound :: i)- }---- | A safe codec for 'Integer'.------ This codec does a bounds check for the range [-10^1024, 10^1024] it can safely parse very large numbers.------ For a codec without this protection, see 'unsafeUnboundedIntegerCodec'.------ === Example usage------ >>> toJSONVia integerCodec 5--- Number 5.0--- >>> toJSONVia integerCodec (-1000000000000)--- Number (-1.0e12)--- >>> JSON.parseMaybe (parseJSONVia integerCodec) (Number (-4.0))--- Just (-4)--- >>> JSON.parseMaybe (parseJSONVia integerCodec) (Number (scientific 1 100000000))--- Nothing-integerCodec :: JSONCodec Integer-integerCodec =- bimapCodec go fromIntegral $- scientificWithBoundsCodec- ( NumberBounds- { numberBoundsLower = scientific (-1) 1024,- numberBoundsUpper = scientific 1 1024- }- )- where- go s = case Scientific.floatingOrInteger s :: Either Float Integer of- Right i -> Right i- Left _ -> Left ("Number is not an integer: " <> show s)+-- You can call this using @TypeApplications@: @boundedIntegralBounds @Word@+boundedIntegralBounds :: forall i. (Integral i, Bounded i) => Bounds Integer+boundedIntegralBounds = fromIntegral <$> boundedBounds @i -- | This is an unsafe (unchecked) version of 'integerCodec'. unsafeUnboundedIntegerCodec :: JSONCodec Integer@@ -1381,36 +1552,6 @@ Right i -> Right i Left _ -> Left ("Number is not an integer: " <> show s) --- | A safe codec for 'Natural'.------ This codec does a bounds check for the range [0, 10^1024] it can safely parse very large numbers.------ For a codec without this protection, see 'unsafeUnboundedNaturalCodec'.------ === Example usage------ >>> toJSONVia naturalCodec 5--- Number 5.0--- >>> toJSONVia naturalCodec (1000000000000)--- Number 1.0e12--- >>> JSON.parseMaybe (parseJSONVia naturalCodec) (Number 4.0)--- Just 4--- >>> JSON.parseMaybe (parseJSONVia naturalCodec) (Number (scientific 1 100000000))--- Nothing-naturalCodec :: JSONCodec Natural-naturalCodec =- bimapCodec go fromIntegral $- scientificWithBoundsCodec- ( NumberBounds- { numberBoundsLower = scientific 0 0,- numberBoundsUpper = scientific 1 1024- }- )- where- go s = case Scientific.floatingOrInteger s :: Either Float Natural of- Right i -> Right i- Left _ -> Left ("Number is not an integer: " <> show s)- -- | This is an unsafe (unchecked) version of 'naturalCodec'. unsafeUnboundedNaturalCodec :: JSONCodec Natural unsafeUnboundedNaturalCodec =@@ -1767,6 +1908,33 @@ ) ) +-- | A codec for a 'Bounded' 'Enum' that uses the provided function to have the values correspond to literal 'Text' values.+--+--+-- === Example usage+--+-- >>> data Fruit = Apple | Orange deriving (Show, Eq, Enum, Bounded)+-- >>> :{+-- let c = boundedEnumCodec $ \case+-- Apple -> "foo"+-- Orange -> "bar"+-- :}+--+-- >>> toJSONVia c Apple+-- String "foo"+-- >>> JSON.parseMaybe (parseJSONVia c) (String "bar") :: Maybe Fruit+-- Just Orange+boundedEnumCodec ::+ forall enum.+ (Eq enum, Enum enum, Bounded enum) =>+ (enum -> T.Text) ->+ JSONCodec enum+boundedEnumCodec showFunc =+ let ls = [minBound .. maxBound]+ in case NE.nonEmpty ls of+ Nothing -> error "0 enum values ?!"+ Just ne -> stringConstCodec (NE.map (\v -> (v, showFunc v)) ne)+ -- | A codec for a 'Bounded' 'Enum' that uses its 'Show' instance to have the values correspond to literal 'Text' values. -- --@@ -1782,11 +1950,7 @@ forall enum. (Show enum, Eq enum, Enum enum, Bounded enum) => JSONCodec enum-shownBoundedEnumCodec =- let ls = [minBound .. maxBound]- in case NE.nonEmpty ls of- Nothing -> error "0 enum values ?!"- Just ne -> stringConstCodec (NE.map (\v -> (v, T.pack (show v))) ne)+shownBoundedEnumCodec = boundedEnumCodec (T.pack . show) -- | Helper function for 'optionalFieldOrNullWith' and 'optionalFieldOrNull'. --@@ -1841,3 +2005,36 @@ Text -> JSONCodec a codecViaAeson doc = bimapCodec (JSON.parseEither JSON.parseJSON) JSON.toJSON valueCodec <?> doc++-- Could get this from https://hackage.haskell.org/package/either-result-0.3.1.0/docs/Control-Monad-Result.html#t:Result+-- but just reimplementing here to avoid a dependency, as it's not exported anyway+-- (well it is actually, until we give this module an explicit export list).+-- We need to do this because `Either String a` doesn't have a `MonadFail` instance,+-- but `Time.iso8601ParseM` expects it's return value to have a `MonadFail` instance.+newtype Result a = Result {runResult :: Either String a}+ deriving newtype (Functor, Applicative, Monad)++instance MonadFail Result where+ fail = Result . Left++-- TODO 'aeson' has it's own custom datetime serialising code in the module @Data.Aeson.Encoding.Builder@:+-- The core function here is `Data.Aeson.Encoding.Builder.timeOfDay64`.+-- However, this module is private.+-- There is @Data.Aeson.Encoding.Internal@, which interestingly isn't private, but it's only exposed functions+-- wrap the return bytestring in a quotes. Only for the quotes to be removed in `Data.Aeson.Types.ToJSON.stringEncoding`+-- This all seems a bit silly.+-- I think `aeson` should just expose @Data.Aeson.Encoding.Builder@ and it's datetime instances should just take those builders,+-- convert them to Text and be done with it.+-- I plan to submit a PR to 'aeson' to do this.+-- In the meantime, I think the best way to ensure we are exactly behaving as 'aeson' is just to _assume_ aeson is returning a string+-- This is a correct assumption for any of the datetime types, but using this function generally is unsafe.+unsafeCodecViaAesonString ::+ (FromJSON a, ToJSON a) =>+ -- | Name+ Text ->+ JSONCodec a+unsafeCodecViaAesonString doc = bimapCodec (JSON.parseEither JSON.parseJSON . JSON.String) (unsafeAesonValueToString . JSON.toJSON) textCodec <?> doc+ where+ unsafeAesonValueToString v = case v of+ JSON.String s -> s+ _ -> error $ "unsafeAesonValueToString failed.\n " ++ show v ++ "\n is not a JSON string."
src/Autodocodec/DerivingVia.hs view
@@ -1,5 +1,10 @@ module Autodocodec.DerivingVia where +import Autodocodec.Aeson.Decode (parseJSONViaCodec)+import Autodocodec.Aeson.Encode (toEncodingViaCodec, toJSONViaCodec)+import Autodocodec.Class (HasCodec)+import qualified Data.Aeson as JSON+ -- | 'Autodocodec' is a wrapper to provide codec-based deriving strategies. -- -- === Example usage@@ -15,3 +20,10 @@ -- > <$> requiredField "one" "first field" .= viaOne -- > <*> requiredField "two" "second field" .= viaTwo newtype Autodocodec a = Autodocodec {unAutodocodec :: a}++instance (HasCodec a) => JSON.ToJSON (Autodocodec a) where+ toJSON = toJSONViaCodec . unAutodocodec+ toEncoding = toEncodingViaCodec . unAutodocodec++instance (HasCodec a) => JSON.FromJSON (Autodocodec a) where+ parseJSON = fmap Autodocodec <$> parseJSONViaCodec