mirror of
https://github.com/NorfairKing/autodocodec.git
synced 2024-10-27 16:20:04 +03:00
eithercodec for objectcodecs, it's a bit cursed but maybe that's ok?
This commit is contained in:
parent
4afd2c5802
commit
63b2a58f7c
@ -1,6 +1,7 @@
|
|||||||
- ignore: { name: "Eta reduce" }
|
- ignore: { name: "Eta reduce" }
|
||||||
- ignore: { name: "Use unless" }
|
- ignore: { name: "Use unless" }
|
||||||
- ignore: { name: "Use fmap" }
|
- ignore: { name: "Use fmap" }
|
||||||
|
- ignore: { name: "Use tuple-section" }
|
||||||
- ignore: { name: "Use ++" }
|
- ignore: { name: "Use ++" }
|
||||||
- ignore: { name: "Avoid lambda using `infix`" }
|
- ignore: { name: "Avoid lambda using `infix`" }
|
||||||
- ignore: { name: "Replace case with maybe" }
|
- ignore: { name: "Replace case with maybe" }
|
||||||
|
@ -259,8 +259,10 @@ jsonSchemaVia = (`evalState` S.empty) . go
|
|||||||
s <- go c
|
s <- go c
|
||||||
pure $ maybe id CommentSchema mname $ ArraySchema s
|
pure $ maybe id CommentSchema mname $ ArraySchema s
|
||||||
ObjectOfCodec mname oc -> do
|
ObjectOfCodec mname oc -> do
|
||||||
s <- goObject oc
|
alts <- goObject oc
|
||||||
pure $ maybe id CommentSchema mname $ ObjectSchema s
|
case alts of
|
||||||
|
s :| [] -> pure $ maybe id CommentSchema mname $ ObjectSchema s
|
||||||
|
_ -> pure $ maybe id CommentSchema mname $ ChoiceSchema $ goChoice $ NE.map ObjectSchema alts
|
||||||
HashMapCodec c -> MapSchema <$> go c
|
HashMapCodec c -> MapSchema <$> go c
|
||||||
MapCodec c -> MapSchema <$> go c
|
MapCodec c -> MapSchema <$> go c
|
||||||
ValueCodec -> pure AnySchema
|
ValueCodec -> pure AnySchema
|
||||||
@ -290,21 +292,26 @@ jsonSchemaVia = (`evalState` S.empty) . go
|
|||||||
ChoiceSchema ss -> goChoice ss
|
ChoiceSchema ss -> goChoice ss
|
||||||
s' -> s' :| []
|
s' -> s' :| []
|
||||||
|
|
||||||
goObject :: ObjectCodec input output -> State (Set Text) [(Text, (KeyRequirement, JSONSchema, Maybe Text))]
|
-- The outer list is for alternatives, the inner list is for multiple keys
|
||||||
|
goObject :: ObjectCodec input output -> State (Set Text) (NonEmpty [(Text, (KeyRequirement, JSONSchema, Maybe Text))])
|
||||||
goObject = \case
|
goObject = \case
|
||||||
RequiredKeyCodec k c mdoc -> do
|
RequiredKeyCodec k c mdoc -> do
|
||||||
s <- go c
|
s <- go c
|
||||||
pure [(k, (Required, s, mdoc))]
|
pure $ [(k, (Required, s, mdoc))] :| []
|
||||||
OptionalKeyCodec k c mdoc -> do
|
OptionalKeyCodec k c mdoc -> do
|
||||||
s <- go c
|
s <- go c
|
||||||
pure [(k, (Optional Nothing, s, mdoc))]
|
pure $ [(k, (Optional Nothing, s, mdoc))] :| []
|
||||||
OptionalKeyWithDefaultCodec k c mr mdoc -> do
|
OptionalKeyWithDefaultCodec k c mr mdoc -> do
|
||||||
s <- go c
|
s <- go c
|
||||||
pure [(k, (Optional (Just (toJSONVia c mr)), s, mdoc))]
|
pure $ [(k, (Optional (Just (toJSONVia c mr)), s, mdoc))] :| []
|
||||||
OptionalKeyWithOmittedDefaultCodec k c defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec k c defaultValue mDoc)
|
OptionalKeyWithOmittedDefaultCodec k c defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec k c defaultValue mDoc)
|
||||||
BimapCodec _ _ c -> goObject c
|
BimapCodec _ _ c -> goObject c
|
||||||
PureCodec _ -> pure []
|
EitherCodec oc1 oc2 -> liftA2 (<>) (goObject oc1) (goObject oc2)
|
||||||
ApCodec oc1 oc2 -> liftA2 (++) (goObject oc1) (goObject oc2)
|
PureCodec _ -> pure $ [] :| []
|
||||||
|
ApCodec oc1 oc2 -> do
|
||||||
|
s1s <- goObject oc1
|
||||||
|
s2s <- goObject oc2
|
||||||
|
pure $ (++) <$> s1s <*> s2s
|
||||||
|
|
||||||
uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
|
uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
|
||||||
uncurry3 f (a, b, c) = f a b c
|
uncurry3 f (a, b, c) = f a b c
|
||||||
|
@ -60,6 +60,9 @@ toYamlVia = flip go
|
|||||||
then []
|
then []
|
||||||
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mDoc)
|
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mDoc)
|
||||||
BimapCodec _ g c -> goObject (g a) c
|
BimapCodec _ g c -> goObject (g a) c
|
||||||
|
EitherCodec oc1 oc2 -> case (a :: Either _ _) of
|
||||||
|
Left a1 -> goObject a1 oc1
|
||||||
|
Right a2 -> goObject a2 oc2
|
||||||
PureCodec _ -> []
|
PureCodec _ -> []
|
||||||
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
|
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
|
||||||
|
|
||||||
@ -67,7 +70,7 @@ toYamlVia = flip go
|
|||||||
yamlNumber :: Scientific -> YamlBuilder
|
yamlNumber :: Scientific -> YamlBuilder
|
||||||
yamlNumber s =
|
yamlNumber s =
|
||||||
if s > 1E1024 || s < -1E1024
|
if s > 1E1024 || s < -1E1024
|
||||||
then Yaml.string $ "Cannot encode super duper large numbers with toYaml:" <> T.pack (show s)
|
then Yaml.string $ "Cannot encode super duper large numbers with toYaml: " <> T.pack (show s)
|
||||||
else Yaml.scientific s
|
else Yaml.scientific s
|
||||||
|
|
||||||
-- Encode a 'JSON.Object'
|
-- Encode a 'JSON.Object'
|
||||||
|
@ -59,6 +59,9 @@ toJSONVia = flip go
|
|||||||
then mempty
|
then mempty
|
||||||
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)
|
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)
|
||||||
BimapCodec _ g c -> goObject (g a) c
|
BimapCodec _ g c -> goObject (g a) c
|
||||||
|
EitherCodec c1 c2 -> case (a :: Either _ _) of
|
||||||
|
Left a1 -> goObject a1 c1
|
||||||
|
Right a2 -> goObject a2 c2
|
||||||
PureCodec _ -> mempty
|
PureCodec _ -> mempty
|
||||||
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
|
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
|
||||||
|
|
||||||
@ -99,6 +102,9 @@ toEncodingVia = flip go
|
|||||||
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)
|
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)
|
||||||
PureCodec _ -> mempty :: JSON.Series
|
PureCodec _ -> mempty :: JSON.Series
|
||||||
BimapCodec _ g c -> goObject (g a) c
|
BimapCodec _ g c -> goObject (g a) c
|
||||||
|
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
|
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
|
||||||
|
|
||||||
instance HasCodec a => JSON.ToJSON (Autodocodec a) where
|
instance HasCodec a => JSON.ToJSON (Autodocodec a) where
|
||||||
|
@ -130,11 +130,11 @@ data Codec context input output where
|
|||||||
-- This codec is used to implement choice.
|
-- This codec is used to implement choice.
|
||||||
EitherCodec ::
|
EitherCodec ::
|
||||||
-- | Codec for the 'Left' side
|
-- | Codec for the 'Left' side
|
||||||
(ValueCodec input1 output1) ->
|
(Codec context input1 output1) ->
|
||||||
-- | Codec for the 'Right' side
|
-- | Codec for the 'Right' side
|
||||||
(ValueCodec input2 output2) ->
|
(Codec context input2 output2) ->
|
||||||
-- |
|
-- |
|
||||||
ValueCodec (Either input1 input2) (Either output1 output2)
|
Codec context (Either input1 input2) (Either output1 output2)
|
||||||
-- | A comment codec
|
-- | A comment codec
|
||||||
--
|
--
|
||||||
-- This is used to add implementation-irrelevant but human-relevant information.
|
-- This is used to add implementation-irrelevant but human-relevant information.
|
||||||
@ -402,9 +402,9 @@ maybeCodec = dimapCodec f g . EitherCodec nullCodec
|
|||||||
-- >>> toJSONVia (eitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Right "hello")
|
-- >>> toJSONVia (eitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Right "hello")
|
||||||
-- String "hello"
|
-- String "hello"
|
||||||
eitherCodec ::
|
eitherCodec ::
|
||||||
ValueCodec input1 output1 ->
|
Codec context input1 output1 ->
|
||||||
ValueCodec input2 output2 ->
|
Codec context input2 output2 ->
|
||||||
ValueCodec (Either input1 input2) (Either output1 output2)
|
Codec context (Either input1 input2) (Either output1 output2)
|
||||||
eitherCodec = EitherCodec
|
eitherCodec = EitherCodec
|
||||||
|
|
||||||
-- | Map a codec's input and output types.
|
-- | Map a codec's input and output types.
|
||||||
@ -791,6 +791,15 @@ matchChoicesCodec ((f, c) :| rest) = case NE.nonEmpty rest of
|
|||||||
(f, c)
|
(f, c)
|
||||||
(Just, matchChoicesCodec ne)
|
(Just, matchChoicesCodec ne)
|
||||||
|
|
||||||
|
-- | Use one codec for the default way of parsing and rendering, but then also
|
||||||
|
-- use a list of other codecs for potentially different parsing.
|
||||||
|
--
|
||||||
|
-- You can use this for keeping old ways of parsing intact while already rendering in the new way.
|
||||||
|
--
|
||||||
|
-- TODO tests
|
||||||
|
parseAlternatives :: ValueCodec input output -> [ValueCodec input output] -> ValueCodec input output
|
||||||
|
parseAlternatives c cRest = matchChoicesCodec $ (Just, c) :| map (\c' -> (const Nothing, c')) cRest
|
||||||
|
|
||||||
enumCodec ::
|
enumCodec ::
|
||||||
forall enum.
|
forall enum.
|
||||||
Eq enum =>
|
Eq enum =>
|
||||||
|
Loading…
Reference in New Issue
Block a user