diff --git a/.hlint.yaml b/.hlint.yaml index 47cfa42..9c07bfa 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -1,6 +1,7 @@ - ignore: { name: "Eta reduce" } - ignore: { name: "Use unless" } - ignore: { name: "Use fmap" } +- ignore: { name: "Use tuple-section" } - ignore: { name: "Use ++" } - ignore: { name: "Avoid lambda using `infix`" } - ignore: { name: "Replace case with maybe" } diff --git a/autodocodec-schema/src/Autodocodec/Schema.hs b/autodocodec-schema/src/Autodocodec/Schema.hs index 9874860..e3eade6 100644 --- a/autodocodec-schema/src/Autodocodec/Schema.hs +++ b/autodocodec-schema/src/Autodocodec/Schema.hs @@ -259,8 +259,10 @@ jsonSchemaVia = (`evalState` S.empty) . go s <- go c pure $ maybe id CommentSchema mname $ ArraySchema s ObjectOfCodec mname oc -> do - s <- goObject oc - pure $ maybe id CommentSchema mname $ ObjectSchema s + alts <- goObject oc + 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 MapCodec c -> MapSchema <$> go c ValueCodec -> pure AnySchema @@ -290,21 +292,26 @@ jsonSchemaVia = (`evalState` S.empty) . go ChoiceSchema ss -> goChoice ss 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 RequiredKeyCodec k c mdoc -> do s <- go c - pure [(k, (Required, s, mdoc))] + pure $ [(k, (Required, s, mdoc))] :| [] OptionalKeyCodec k c mdoc -> do s <- go c - pure [(k, (Optional Nothing, s, mdoc))] + pure $ [(k, (Optional Nothing, s, mdoc))] :| [] OptionalKeyWithDefaultCodec k c mr mdoc -> do 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) BimapCodec _ _ c -> goObject c - PureCodec _ -> pure [] - ApCodec oc1 oc2 -> liftA2 (++) (goObject oc1) (goObject oc2) + EitherCodec 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 f (a, b, c) = f a b c diff --git a/autodocodec-yaml/src/Autodocodec/Yaml/Encode.hs b/autodocodec-yaml/src/Autodocodec/Yaml/Encode.hs index 48b9c3e..471d4b7 100644 --- a/autodocodec-yaml/src/Autodocodec/Yaml/Encode.hs +++ b/autodocodec-yaml/src/Autodocodec/Yaml/Encode.hs @@ -60,6 +60,9 @@ toYamlVia = flip go then [] else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mDoc) 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 _ -> [] ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2 @@ -67,7 +70,7 @@ toYamlVia = flip go yamlNumber :: Scientific -> YamlBuilder yamlNumber s = 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 -- Encode a 'JSON.Object' diff --git a/autodocodec/src/Autodocodec/Aeson/Encode.hs b/autodocodec/src/Autodocodec/Aeson/Encode.hs index c9e6d5e..0e8f3fb 100644 --- a/autodocodec/src/Autodocodec/Aeson/Encode.hs +++ b/autodocodec/src/Autodocodec/Aeson/Encode.hs @@ -59,6 +59,9 @@ toJSONVia = flip go then mempty else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc) 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 ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2 @@ -99,6 +102,9 @@ toEncodingVia = flip go 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 + Left a1 -> goObject a1 c1 + Right a2 -> goObject a2 c2 ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2 instance HasCodec a => JSON.ToJSON (Autodocodec a) where diff --git a/autodocodec/src/Autodocodec/Codec.hs b/autodocodec/src/Autodocodec/Codec.hs index 9bb598e..1e5af93 100644 --- a/autodocodec/src/Autodocodec/Codec.hs +++ b/autodocodec/src/Autodocodec/Codec.hs @@ -130,11 +130,11 @@ data Codec context input output where -- This codec is used to implement choice. EitherCodec :: -- | Codec for the 'Left' side - (ValueCodec input1 output1) -> + (Codec context input1 output1) -> -- | 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 -- -- 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") -- String "hello" eitherCodec :: - ValueCodec input1 output1 -> - ValueCodec input2 output2 -> - ValueCodec (Either input1 input2) (Either output1 output2) + Codec context input1 output1 -> + Codec context input2 output2 -> + Codec context (Either input1 input2) (Either output1 output2) eitherCodec = EitherCodec -- | Map a codec's input and output types. @@ -791,6 +791,15 @@ matchChoicesCodec ((f, c) :| rest) = case NE.nonEmpty rest of (f, c) (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 :: forall enum. Eq enum =>