autodocodec 0.0.0.0 → 0.0.1.0
raw patch · 7 files changed
+239/−34 lines, 7 files
Files
- CHANGELOG.md +10/−0
- autodocodec.cabal +2/−2
- src/Autodocodec.hs +28/−14
- src/Autodocodec/Aeson/Decode.hs +19/−5
- src/Autodocodec/Aeson/Encode.hs +4/−4
- src/Autodocodec/Class.hs +1/−1
- src/Autodocodec/Codec.hs +175/−8
CHANGELOG.md view
@@ -1,5 +1,15 @@ # Changelog +## [0.0.1.0] - 2021-12-23++### Changed++* `EitherCodec` now takes a `Union` to specify whether the union is disjoint or not.++### Added++* `disjointEitherCodec` and `possiblyJointEitherCodec`.+ ## [0.0.0.0] - 2021-11-19 First release.
autodocodec.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.34.5. -- -- see: https://github.com/sol/hpack name: autodocodec-version: 0.0.0.0+version: 0.0.1.0 synopsis: Self-documenting encoder and decoder homepage: https://github.com/NorfairKing/autodocodec#readme bug-reports: https://github.com/NorfairKing/autodocodec/issues
src/Autodocodec.hs view
@@ -57,36 +57,46 @@ optionalFieldOrNullWithOmittedDefaultWith', -- ** Writing your own value codecs.- maybeCodec,- eitherCodec,- listCodec,- nonEmptyCodec,- singleOrListCodec,- singleOrNonEmptyCodec,- vectorCodec,- valueCodec,++ -- *** Primitive codecs nullCodec, boolCodec, textCodec, stringCodec, scientificCodec,+ valueCodec,++ -- *** Integral codecs boundedIntegralCodec, boundedIntegralNumberBounds,++ -- *** Literal value codecs literalTextCodec, literalTextValueCodec,- (<?>),- (<??>), + -- *** Enums+ shownBoundedEnumCodec,+ stringConstCodec,+ enumCodec,++ -- *** Sum type codecs+ eitherCodec,+ disjointEitherCodec,+ possiblyJointEitherCodec,+ -- *** Mapping dimapCodec, bimapCodec, rmapCodec, lmapCodec, - -- *** Enums- shownBoundedEnumCodec,- stringConstCodec,- enumCodec,+ -- *** Composing codecs+ maybeCodec,+ listCodec,+ nonEmptyCodec,+ singleOrListCodec,+ singleOrNonEmptyCodec,+ vectorCodec, -- *** Alternative parsing parseAlternative,@@ -95,6 +105,10 @@ -- *** Choice matchChoiceCodec, matchChoicesCodec,++ -- *** Adding documentation to a codec+ (<?>),+ (<??>), -- * Bare codec Codec (..),
src/Autodocodec/Aeson/Decode.hs view
@@ -88,12 +88,26 @@ case f old of Left err -> fail err Right new -> pure new- EitherCodec c1 c2 ->+ EitherCodec u c1 c2 -> let leftParser = (\v -> Left <$> go v c1)- rightParser = Right <$> go value c2- in case parseEither leftParser value of- Right l -> pure l- Left err -> prependFailure (" Previous branch failure: " <> err <> "\n") rightParser+ rightParser = (\v -> Right <$> go v c2)+ in 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+ (Right _, Right _) -> fail "Both branches of a disjoint union succeeded."+ (Left lErr, Left rErr) ->+ fail $+ unlines+ [ "Both branches of a disjoint union failed: ",+ unwords ["Left: ", lErr],+ unwords ["Right: ", rErr]+ ] CommentCodec _ c -> go value c ReferenceCodec _ c -> go value c RequiredKeyCodec k c _ -> do
src/Autodocodec/Aeson/Encode.hs view
@@ -41,7 +41,7 @@ ValueCodec -> (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 (a :: Either _ _) of Left a1 -> go a1 c1 Right a2 -> go a2 c2 CommentCodec _ c -> go a c@@ -60,7 +60,7 @@ else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc) BimapCodec _ g c -> goObject (g a) c PureCodec _ -> mempty- EitherCodec c1 c2 -> case (a :: Either _ _) of+ EitherCodec _ c1 c2 -> case (a :: Either _ _) of Left a1 -> goObject a1 c1 Right a2 -> goObject a2 c2 ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2@@ -86,7 +86,7 @@ ValueCodec -> JSON.value (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 (a :: Either _ _) of Left a1 -> go a1 c1 Right a2 -> go a2 c2 CommentCodec _ c -> go a c@@ -104,7 +104,7 @@ else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc) PureCodec _ -> mempty :: JSON.Series BimapCodec _ g c -> goObject (g a) c- EitherCodec c1 c2 -> case (a :: Either _ _) of+ EitherCodec _ c1 c2 -> case (a :: Either _ _) of Left a1 -> goObject a1 c1 Right a2 -> goObject a2 c2 ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
src/Autodocodec/Class.hs view
@@ -103,7 +103,7 @@ instance (HasCodec l, HasCodec r) => HasCodec (Either l r) where codec =- eitherCodec+ disjointEitherCodec (ObjectOfCodec Nothing (requiredField' "Left")) (ObjectOfCodec Nothing (requiredField' "Right"))
src/Autodocodec/Codec.hs view
@@ -33,15 +33,17 @@ import GHC.Generics (Generic) -- $setup--- >>> import Autodocodec.Aeson (toJSONVia, parseJSONVia)--- >>> import Autodocodec.Class (HasCodec(codec))+-- >>> import Autodocodec.Aeson (toJSONVia, toJSONViaCodec, parseJSONVia, parseJSONViaCodec)+-- >>> import Autodocodec.Class (HasCodec(codec), requiredField) -- >>> import qualified Data.Aeson as JSON+-- >>> import qualified Data.HashMap.Strict as HM -- >>> import Data.Aeson (Value(..)) -- >>> import qualified Data.Vector as Vector -- >>> import Data.Int -- >>> import Data.Word -- >>> :set -XOverloadedStrings -- >>> :set -XOverloadedLists+-- >>> :set -XLambdaCase -- | A Self-documenting encoder and decoder, --@@ -158,6 +160,8 @@ -- In particular, you should prefer using it for values rather than objects, -- because those docs are easier to generate. EitherCodec ::+ -- | What type of union we encode and decode+ !Union -> -- | Codec for the 'Left' side (Codec context input1 output1) -> -- | Codec for the 'Right' side@@ -256,6 +260,7 @@ instance Validity NumberBounds +-- | Check if a number falls within given 'NumberBounds'. checkNumberBounds :: NumberBounds -> Scientific -> Either String Scientific checkNumberBounds NumberBounds {..} s = if numberBoundsLower <= s@@ -265,6 +270,16 @@ 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] +-- | What type of union the encoding uses+data Union+ = -- | Not disjoint, see 'possiblyJointEitherCodec'.+ PossiblyJointUnion+ | -- | Disjoint, see 'disjointEitherCodec'.+ DisjointUnion+ deriving (Show, Eq, Generic)++instance Validity Union+ -- | A codec within the 'JSON.Value' context. -- -- An 'ValueCodec' can be used to turn a Haskell value into a 'JSON.Value' or to parse a 'JSON.Value' into a haskell value.@@ -315,7 +330,7 @@ HashMapCodec c -> (\s -> showParen (d > 10) $ showString "HashMapCodec" . s) <$> go 11 c 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 c1 c2 -> (\s1 s2 -> showParen (d > 10) $ showString "EitherCodec " . s1 . showString " " . s2) <$> go 11 c1 <*> go 11 c2+ EitherCodec u c1 c2 -> (\s1 s2 -> showParen (d > 10) $ showString "EitherCodec " . showsPrec 11 u . showString " " . s1 . showString " " . s2) <$> go 11 c1 <*> go 11 c2 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)@@ -390,6 +405,9 @@ -- -- You can use this function to change the type of a codec as long as the two -- functions are inverses.+--+-- === 'HasCodec' instance for newtypes+-- -- A good use-case is implementing 'HasCodec' for newtypes: -- -- > newtype MyInt = MyInt { unMyInt :: Int }@@ -434,7 +452,11 @@ -- >>> toJSONVia (maybeCodec codec) (Nothing :: Maybe Char) -- Null maybeCodec :: ValueCodec input output -> ValueCodec (Maybe input) (Maybe output)-maybeCodec = dimapCodec f g . EitherCodec nullCodec+maybeCodec =+ -- We must use 'possiblyJointEitherCodec' here, otherwise a codec for (Maybe+ -- (Maybe Text)) will fail to parse.+ dimapCodec f g+ . possiblyJointEitherCodec nullCodec where f = \case Left () -> Nothing@@ -445,19 +467,164 @@ -- | Forward-compatible version of 'EitherCodec' ----- > eitherCodec = EitherCodec+-- > eitherCodec = EitherCodec PossiblyJointUnion --+-- === 'HasCodec' instance for sum types+--+-- To write a 'HasCodec' instance for sum types, you will need to decide whether encoding is disjoint or not.+-- The default, so also the implementation of this function, is 'possiblyJointEitherCodec', but you may want to use 'disjointEitherCodec' instead.+--+-- Ask yourself: Can the encoding of a 'Left' value be decoded as 'Right' value (or vice versa)?+--+-- @Yes ->@ use 'possiblyJointEitherCodec'.+--+-- @No ->@ use 'disjointEitherCodec'.+-- -- === Example usage ----- >>> toJSONVia (eitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Left 5)+-- >>> let c = eitherCodec codec codec :: JSONCodec (Either Int String)+-- >>> toJSONVia c (Left 5) -- Number 5.0--- >>> toJSONVia (eitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Right "hello")+-- >>> toJSONVia c (Right "hello") -- String "hello"+-- >>> JSON.parseMaybe (parseJSONVia c) (String "world") :: Maybe (Either Int String)+-- Just (Right "world") eitherCodec ::+ -- | Codec context input1 output1 ->+ -- | Codec context input2 output2 ->+ -- | Codec context (Either input1 input2) (Either output1 output2)-eitherCodec = EitherCodec+eitherCodec = possiblyJointEitherCodec++-- | Forward-compatible version of 'EitherCodec PossiblyJointUnion'+--+-- > possiblyJointEitherCodec = EitherCodec PossiblyJointUnion+--+-- === 'HasCodec' instance for sum types with an encoding that is not disjoint.+--+-- The 'eitherCodec' can be used to implement 'HasCodec' instances for sum types.+-- If you just have two codecs that you want to try in order, while parsing, you can do this:+--+-- >>> :{+-- data Ainur+-- = Valar Text Text+-- | Maiar Text+-- deriving (Show, Eq)+-- :}+--+-- >>> :{+-- instance HasCodec Ainur where+-- codec =+-- dimapCodec f g $+-- possiblyJointEitherCodec+-- (object "Valar" $+-- (,)+-- <$> requiredField "domain" "Domain which the Valar rules over" .= fst+-- <*> requiredField "name" "Name of the Valar" .= snd)+-- (object "Maiar" $ requiredField "name" "Name of the Maiar")+-- where+-- f = \case+-- Left (domain, name) -> Valar domain name+-- Right name -> Maiar name+-- g = \case+-- Valar domain name -> Left (domain, name)+-- Maiar name -> Right name+-- :}+--+-- Note that this encoding is indeed not disjoint, because a @Valar@ object can+-- parse as a @Maiar@ value.+--+-- >>> toJSONViaCodec (Valar "Stars" "Varda")+-- Object (fromList [("domain",String "Stars"),("name",String "Varda")])+-- >>> toJSONViaCodec (Maiar "Sauron")+-- Object (fromList [("name",String "Sauron")])+-- >>> JSON.parseMaybe parseJSONViaCodec (Object (HM.fromList [("name",String "Olorin")])) :: Maybe Ainur+-- Just (Maiar "Olorin")+--+-- === WARNING+--+-- The order of the codecs in a 'possiblyJointEitherCodec' matters.+--+-- In the above example, decoding works as expected because the @Valar@ case is parsed first.+-- If the @Maiar@ case were first in the 'possiblyJointEitherCodec', then+-- @Valar@ could never be parsed.+possiblyJointEitherCodec ::+ -- |+ Codec context input1 output1 ->+ -- |+ Codec context input2 output2 ->+ -- |+ Codec context (Either input1 input2) (Either output1 output2)+possiblyJointEitherCodec = EitherCodec PossiblyJointUnion++-- | Forward-compatible version of 'EitherCodec DisjointUnion'+--+-- > disjointEitherCodec = EitherCodec DisjointUnion+--+-- === 'HasCodec' instance for sum types with an encoding that is definitely disjoint.+--+-- The 'eitherCodec' can be used to implement 'HasCodec' instances sum types+-- for which the encoding is definitely disjoint.+--+-- >>> data War = WorldWar Word8 | OtherWar Text deriving (Show, Eq)+-- >>> :{+-- instance HasCodec War where+-- codec =+-- dimapCodec f g $+-- disjointEitherCodec+-- (codec :: JSONCodec Word8)+-- (codec :: JSONCodec Text)+-- where+-- f = \case+-- Left w -> WorldWar w+-- Right t -> OtherWar t+-- g = \case+-- WorldWar w -> Left w+-- OtherWar t -> Right t+-- :}+--+-- Note that this incoding is indeed disjoint because an encoded 'String' can+-- never be parsed as an 'Word8' and vice versa.+--+-- >>> toJSONViaCodec (WorldWar 2)+-- Number 2.0+-- >>> toJSONViaCodec (OtherWar "OnDrugs")+-- String "OnDrugs"+-- >>> JSON.parseMaybe parseJSONViaCodec (String "of the roses") :: Maybe War+-- Just (OtherWar "of the roses")+--+-- === WARNING+--+-- If it turns out that the encoding of a value is not disjoint, decoding may+-- fail and documentation may be wrong.+--+-- >>> let c = disjointEitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec Int)+-- >>> JSON.parseMaybe (parseJSONVia c) (Number 5) :: Maybe (Either Int Int)+-- Nothing+--+-- Encoding still works as expected, however:+--+-- >>> toJSONVia c (Left 5)+-- Number 5.0+-- >>> toJSONVia c (Right 6)+-- Number 6.0+--+-- === Example usage+--+-- >>> toJSONVia (disjointEitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Left 5)+-- Number 5.0+-- >>> toJSONVia (disjointEitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Right "hello")+-- String "hello"+disjointEitherCodec ::+ -- |+ Codec context input1 output1 ->+ -- |+ Codec context input2 output2 ->+ -- |+ Codec context (Either input1 input2) (Either output1 output2)+disjointEitherCodec = EitherCodec DisjointUnion -- | Map a codec's input and output types. --