diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/autodocodec.cabal b/autodocodec.cabal --- a/autodocodec.cabal +++ b/autodocodec.cabal @@ -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 diff --git a/src/Autodocodec.hs b/src/Autodocodec.hs --- a/src/Autodocodec.hs +++ b/src/Autodocodec.hs @@ -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 (..), diff --git a/src/Autodocodec/Aeson/Decode.hs b/src/Autodocodec/Aeson/Decode.hs --- a/src/Autodocodec/Aeson/Decode.hs +++ b/src/Autodocodec/Aeson/Decode.hs @@ -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 diff --git a/src/Autodocodec/Aeson/Encode.hs b/src/Autodocodec/Aeson/Encode.hs --- a/src/Autodocodec/Aeson/Encode.hs +++ b/src/Autodocodec/Aeson/Encode.hs @@ -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 diff --git a/src/Autodocodec/Class.hs b/src/Autodocodec/Class.hs --- a/src/Autodocodec/Class.hs +++ b/src/Autodocodec/Class.hs @@ -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")) diff --git a/src/Autodocodec/Codec.hs b/src/Autodocodec/Codec.hs --- a/src/Autodocodec/Codec.hs +++ b/src/Autodocodec/Codec.hs @@ -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. --