diff --git a/autodocodec-aeson/src/Autodocodec/Aeson/Decode.hs b/autodocodec-aeson/src/Autodocodec/Aeson/Decode.hs index 866efc8..0bbb130 100644 --- a/autodocodec-aeson/src/Autodocodec/Aeson/Decode.hs +++ b/autodocodec-aeson/src/Autodocodec/Aeson/Decode.hs @@ -9,7 +9,6 @@ import Control.Applicative import Control.Monad import Data.Aeson as JSON import Data.Aeson.Types as JSON -import Data.Foldable import qualified Data.HashMap.Strict as HM import qualified Data.Text as T @@ -25,11 +24,25 @@ parseJSONVia = flip go NullCodec -> case value of Null -> pure () _ -> fail $ "Expected Null, but got: " <> show value - BoolCodec -> parseJSON value - StringCodec -> parseJSON value - NumberCodec -> parseJSON value - ArrayCodec mname c -> withArray (maybe "Unnamed" T.unpack mname) (mapM (`go` c)) value - ObjectCodec mname c -> withObject (maybe "Unnamed" T.unpack mname) (\o -> goObject o c) value + BoolCodec mname -> case mname of + Nothing -> parseJSON value + Just name -> withBool (T.unpack name) pure value + StringCodec mname -> case mname of + Nothing -> parseJSON value + Just name -> withText (T.unpack name) pure value + NumberCodec mname -> case mname of + Nothing -> parseJSON value + Just name -> withScientific (T.unpack name) pure value + ArrayCodec mname c -> do + vector <- case mname of + Nothing -> parseJSON value + Just name -> withArray (T.unpack name) pure value + mapM (`go` c) vector + ObjectCodec mname c -> do + object_ <- case mname of + Nothing -> parseJSON value + Just name -> withObject (T.unpack name) pure value + (`goObject` c) object_ EqCodec expected c -> do actual <- go value c if expected == actual diff --git a/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs b/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs index 3bca46c..ded3436 100644 --- a/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs +++ b/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs @@ -260,9 +260,9 @@ jsonSchemaVia = go go = \case ValueCodec -> AnySchema NullCodec -> NullSchema - BoolCodec -> BoolSchema - StringCodec -> StringSchema - NumberCodec -> NumberSchema + BoolCodec mname -> maybe id CommentSchema mname BoolSchema + StringCodec mname -> maybe id CommentSchema mname StringSchema + NumberCodec mname -> maybe id CommentSchema mname NumberSchema ArrayCodec mname c -> maybe id CommentSchema mname $ ArraySchema (go c) ObjectCodec mname oc -> maybe id CommentSchema mname $ ObjectSchema (goObject oc) EqCodec value c -> ValueSchema (toJSONVia c value) diff --git a/autodocodec-aeson/src/Autodocodec/Aeson/Encode.hs b/autodocodec-aeson/src/Autodocodec/Aeson/Encode.hs index c04c872..612f2f0 100644 --- a/autodocodec-aeson/src/Autodocodec/Aeson/Encode.hs +++ b/autodocodec-aeson/src/Autodocodec/Aeson/Encode.hs @@ -19,9 +19,9 @@ toJSONVia = flip go go a = \case ValueCodec -> a NullCodec -> JSON.Null - BoolCodec -> toJSON (a :: Bool) - StringCodec -> toJSON (a :: Text) - NumberCodec -> toJSON (a :: Scientific) + BoolCodec _ -> toJSON (a :: Bool) + StringCodec _ -> toJSON (a :: Text) + NumberCodec _ -> toJSON (a :: Scientific) ArrayCodec _ c -> toJSON (fmap (`go` c) a) ObjectCodec _ oc -> JSON.Object (goObject a oc) EqCodec value c -> go value c diff --git a/autodocodec/src/Autodocodec/Codec.hs b/autodocodec/src/Autodocodec/Codec.hs index 5cae92c..56b6d87 100644 --- a/autodocodec/src/Autodocodec/Codec.hs +++ b/autodocodec/src/Autodocodec/Codec.hs @@ -41,12 +41,16 @@ data Codec input output where Codec () () -- | Encode a 'Bool' to a @boolean@ value, and decode a @boolean@ value as a 'Bool'. BoolCodec :: + -- | Name of the @bool@, for error messages and documentation. + !(Maybe Text) -> -- | Codec Bool Bool -- | Encode 'Text' to a @string@ value, and decode a @string@ value as a 'Text'. -- -- This is named after the primitive type "String" in json, not after the haskell type string. StringCodec :: + -- | Name of the @string@, for error messages and documentation. + !(Maybe Text) -> -- | Codec Text Text -- | Encode 'Scientific' to a @number@ value, and decode a @number@ value as a 'Scientific'. @@ -54,18 +58,21 @@ data Codec input output where -- NOTE: We use 'Scientific' here because that is what aeson uses. -- TODO: Can we do this without 'Scientific'? It has too many footguns. NumberCodec :: + -- | Name of the @number@, for error messages and documentation. + !(Maybe Text) -> -- | Codec Scientific Scientific -- | Encode a 'Vector' of values as an @array@ value, and decode an @array@ value as a 'Vector' of values. ArrayCodec :: - -- | Name of the array, for error messages and documentation. + -- | Name of the @array@, for error messages and documentation. !(Maybe Text) -> -- | !(Codec input output) -> -- | Codec (Vector input) (Vector output) + -- | Encode a value as a an @object@ value using the given 'ObjectCodec', and decode an @object@ value as a value using the given 'ObjectCodec'. ObjectCodec :: - -- | Name of the array, for error messages and documentation. + -- | Name of the @object@, for error messages and documentation. !(Maybe Text) -> -- | !(ObjectCodec value value) -> @@ -138,11 +145,11 @@ showCodecABit = ($ "") . (`evalState` S.empty) . go 0 go d = \case ValueCodec -> pure $ showString "ValueCodec" NullCodec -> pure $ showString "NullCodec" - BoolCodec -> pure $ showString "BoolCodec" - StringCodec -> pure $ showString "StringCodec" - NumberCodec -> pure $ showString "NumberCodec" - ArrayCodec name c -> (\s -> showParen (d > 10) $ showString "ArrayCodec " . showsPrec d name . showString " " . s) <$> go 11 c - ObjectCodec name oc -> (\s -> showParen (d > 10) $ showString "ObjectCodec " . showsPrec d name . showString " " . s) <$> goObject 11 oc + BoolCodec mname -> pure $ showParen (d > 10) $ showString "BoolCodec " . showsPrec d mname + StringCodec mname -> pure $ showParen (d > 10) $ showString "StringCodec " . showsPrec d mname + NumberCodec mname -> pure $ showParen (d > 10) $ showString "NumberCodec " . showsPrec d mname + ArrayCodec mname c -> (\s -> showParen (d > 10) $ showString "ArrayCodec " . showsPrec d mname . showString " " . s) <$> go 11 c + ObjectCodec mname oc -> (\s -> showParen (d > 10) $ showString "ObjectCodec " . showsPrec d mname . showString " " . s) <$> goObject 11 oc EqCodec value c -> (\s -> showParen (d > 10) $ showString "EqCodec " . showsPrec d value . showString " " . s) <$> go 11 c MapCodec _ _ c -> (\s -> showParen (d > 10) $ showString "MapCodec " . s) <$> go 11 c EitherCodec c1 c2 -> (\s1 s2 -> showParen (d > 10) $ showString "EitherCodec " . s1 . showString " " . s2) <$> go 11 c1 <*> go 11 c2 @@ -306,22 +313,22 @@ nullCodec :: Codec () () nullCodec = NullCodec boolCodec :: Codec Bool Bool -boolCodec = BoolCodec +boolCodec = BoolCodec Nothing textCodec :: Codec Text Text -textCodec = StringCodec +textCodec = StringCodec Nothing stringCodec :: Codec String String -stringCodec = bimapCodec T.unpack T.pack StringCodec +stringCodec = bimapCodec T.unpack T.pack $ StringCodec Nothing scientificCodec :: Codec Scientific Scientific -scientificCodec = NumberCodec +scientificCodec = NumberCodec Nothing object :: Text -> ObjectCodec value value -> Codec value value object name = ObjectCodec (Just name) boundedIntegerCodec :: (Integral i, Bounded i) => Codec i i -boundedIntegerCodec = MapCodec go fromIntegral NumberCodec +boundedIntegerCodec = MapCodec go fromIntegral $ NumberCodec Nothing where go s = case Scientific.toBoundedInteger s of Nothing -> Left $ "Number too big: " <> show s