autodocodec 0.1.0.3 → 0.2.0.0

raw patch · 8 files changed

+122/−2 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• LICENSE +1/−1
• autodocodec.cabal +1/−1
• src/Autodocodec.hs +5/−0
• src/Autodocodec/Aeson/Compat.hs +8/−0
• src/Autodocodec/Aeson/Decode.hs +7/−0
• src/Autodocodec/Aeson/Encode.hs +8/−0
• src/Autodocodec/Codec.hs +86/−0

@@ -1,5 +1,11 @@ # Changelog +## [0.2.0.0] - 2022-07-21++### Added++* `discriminatedUnionCodec` for discriminated unions+ ## [0.1.0.3] - 2022-07-14  ### Changed

@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2021 Tom Sydney Kerckhove+Copyright (c) 2021-2022 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

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           autodocodec-version:        0.1.0.3+version:        0.2.0.0 synopsis:       Self-documenting encoder and decoder homepage:       https://github.com/NorfairKing/autodocodec#readme bug-reports:    https://github.com/NorfairKing/autodocodec/issues

@@ -85,6 +85,11 @@     disjointEitherCodec,     possiblyJointEitherCodec, +    -- **** Discriminated unions+    mapToEncoder,+    mapToDecoder,+    discriminatedUnionCodec,+     -- *** Mapping     dimapCodec,     bimapCodec,

@@ -36,6 +36,14 @@ #endif  #if MIN_VERSION_aeson(2,0,0)+insert :: Key -> v -> KM.KeyMap v -> KM.KeyMap v+insert = KM.insert+#else+insert :: Text -> v -> HM.HashMap Text v -> HM.HashMap Text v+insert = HM.insert+#endif++#if MIN_VERSION_aeson(2,0,0) fromList :: [(Key, v)] -> KM.KeyMap v fromList = KM.fromList #else

@@ -14,6 +14,7 @@ import Data.Aeson as JSON import Data.Aeson.Types as JSON import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import qualified Data.Text as T import Data.Vector (Vector)@@ -108,6 +109,12 @@                           unwords ["Left:  ", lErr],                           unwords ["Right: ", rErr]                         ]+      DiscriminatedUnionCodec propertyName _ m -> do+        discriminatorValue <- (value :: JSON.Object) JSON..: Compat.toKey propertyName+        case HashMap.lookup discriminatorValue m of+          Nothing -> fail $ "Unexpected discriminator value: " <> T.unpack discriminatorValue+          Just (_, c) ->+            go value c       CommentCodec _ c -> go value c       ReferenceCodec _ c -> go value c       RequiredKeyCodec k c _ -> do

@@ -64,6 +64,10 @@       EitherCodec _ c1 c2 -> case (a :: Either _ _) of         Left a1 -> goObject a1 c1         Right a2 -> goObject a2 c2+      DiscriminatedUnionCodec propertyName mapping _ ->+        case mapping a of+          (discriminatorValue, c) ->+            Compat.insert (Compat.toKey propertyName) (JSON.String discriminatorValue) $ goObject a c       ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2  -- | Implement 'JSON.toEncoding' via a type's codec.@@ -108,6 +112,10 @@       EitherCodec _ c1 c2 -> case (a :: Either _ _) of         Left a1 -> goObject a1 c1         Right a2 -> goObject a2 c2+      DiscriminatedUnionCodec propertyName mapping _ ->+        case mapping a of+          (discriminatorValue, c) ->+            JSON.pair (Compat.toKey propertyName) (JSON.toEncoding discriminatorValue) <> goObject a c       ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2  instance HasCodec a => JSON.ToJSON (Autodocodec a) where

@@ -22,7 +22,9 @@ #endif import qualified Data.Aeson.Types as JSON import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Data.Hashable+import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Map (Map)@@ -35,6 +37,7 @@ import Data.Validity.Scientific () import Data.Vector (Vector) import qualified Data.Vector as V+import Data.Void import GHC.Generics (Generic)  -- $setup@@ -156,6 +159,31 @@     -- | Codec for the 'Right' side     Codec context input2 output2 ->     Codec context (Either input1 input2) (Either output1 output2)+  -- | Encode/decode a discriminated union of objects+  --+  -- The type of object being encoded/decoded is discriminated by+  -- a designated "discriminator" property on the object which takes a string value.+  --+  -- When encoding, the provided function is applied to the input to obtain a new encoder+  -- for the input. The function 'mapToEncoder' is provided to assist with building these+  -- encoders.+  --+  -- When decoding, the value of the discriminator property is looked up in the `HashMap`+  -- to obtain a decoder for the output. The function `mapToDecoder' is provided+  -- to assist with building these decoders. See examples in 'Usage.hs'.+  --+  -- The 'HashMap' is also used to generate schemas for the type.+  -- In particular, for OpenAPI 3, it will generate a schema with a 'discriminator', as defined+  -- by https://swagger.io/docs/specification/data-models/inheritance-and-polymorphism/+  DiscriminatedUnionCodec ::+    -- | propertyName to use for discrimination+    Text ->+    -- | how to encode the input+    (input -> (Discriminator, ObjectCodec input ())) ->+    -- | how to decode the output+    -- The 'Text' field is the name to use for the object schema.+    HashMap Discriminator (Text, ObjectCodec Void output) ->+    ObjectCodec input output   -- | A comment codec   --   -- This is used to add implementation-irrelevant but human-relevant information.@@ -309,6 +337,10 @@       EqCodec value c -> (\s -> showParen (d > 10) $ showString "EqCodec " . showsPrec 11 value . showString " " . s) <$> go 11 c       BimapCodec _ _ c -> (\s -> showParen (d > 10) $ showString "BimapCodec _ _ " . s) <$> go 11 c       EitherCodec u c1 c2 -> (\s1 s2 -> showParen (d > 10) $ showString "EitherCodec " . showsPrec 11 u . showString " " . s1 . showString " " . s2) <$> go 11 c1 <*> go 11 c2+      DiscriminatedUnionCodec propertyName _ mapping -> do+        cs <- traverse (\(n, (_, c)) -> (\s -> showParen True $ shows n . showString ", " . s) <$> go 11 c) $ HashMap.toList mapping+        let csList = showString "[" . foldr (.) id (intersperse (showString ", ") cs) . showString "]"+        pure $ showParen (d > 10) $ showString "DiscriminatedUnionCodec " . showsPrec 11 propertyName . showString " _ " . csList       CommentCodec comment c -> (\s -> showParen (d > 10) $ showString "CommentCodec " . showsPrec 11 comment . showString " " . s) <$> go 11 c       ReferenceCodec name c -> do         alreadySeen <- gets (S.member name)@@ -642,6 +674,60 @@   Codec context input2 output2 ->   Codec context (Either input1 input2) (Either output1 output2) possiblyJointEitherCodec = EitherCodec PossiblyJointUnion++-- | Discriminator value used in 'DiscriminatedUnionCodec'+type Discriminator = Text++-- | Wrap up a value of type 'b' with its codec to produce+-- and encoder for 'a's that ignores its input and instead encodes+-- the value 'b'.+-- This is useful for building 'discriminatedUnionCodec's.+mapToEncoder :: b -> Codec context b any -> Codec context a ()+mapToEncoder b = dimapCodec (const ()) (const b)++-- | Map a codec for decoding 'b's into a decoder for 'a's.+-- This is useful for building 'discriminatedUnionCodec's.+mapToDecoder :: (b -> a) -> Codec context any b -> Codec context Void a+mapToDecoder f = dimapCodec f absurd++-- | Encode/decode a discriminated union of objects+--+-- The type of object being encoded/decoded is discriminated by+-- a designated "discriminator" property on the object which takes a string value.+--+-- When encoding, the provided function is applied to the input to obtain a new encoder+-- for the input. The function 'mapToEncoder' is provided to assist with building these+-- encoders. See examples in 'Usage.hs'.+--+-- When decoding, the value of the discriminator property is looked up in the `HashMap`+-- to obtain a decoder for the output. The function `mapToDecoder' is provided+-- to assist with building these decoders. See examples in 'Usage.hs'.+--+-- The 'HashMap' is also used to generate schemas for the type.+-- In particular, for OpenAPI 3, it will generate a schema with a 'discriminator', as defined+-- by https://swagger.io/docs/specification/data-models/inheritance-and-polymorphism/+--+--+-- ==== API Note+--+-- This is a forward-compatible version of 'DiscriminatedUnionCodec'.+--+-- > discriminatedUnionCodec = 'DiscriminatedUnionCodec'+discriminatedUnionCodec ::+  -- | propertyName+  Text ->+  -- | how to encode the input+  --+  -- Use 'mapToEncoder' to produce the 'ObjectCodec's.+  (input -> (Discriminator, ObjectCodec input ())) ->+  -- | how to decode the output+  --+  -- The 'Text' field is the name to use for the object schema.+  --+  -- Use 'mapToDecoder' to produce the 'ObjectCodec's.+  HashMap Discriminator (Text, ObjectCodec Void output) ->+  ObjectCodec input output+discriminatedUnionCodec = DiscriminatedUnionCodec  -- | Map a codec's input and output types. --