mirror of
https://github.com/NorfairKing/autodocodec.git
synced 2024-10-27 16:20:04 +03:00
char and string instances
This commit is contained in:
parent
ab98d6600b
commit
eb92a49449
@ -7,6 +7,7 @@ import Autodocodec
|
||||
import Control.Applicative
|
||||
import Data.Aeson as JSON
|
||||
import Data.Aeson.Types as JSON
|
||||
import Data.Foldable
|
||||
|
||||
parseJSONViaCodec :: HasCodec a => JSON.Value -> JSON.Parser a
|
||||
parseJSONViaCodec = parseJSONVia codec
|
||||
@ -20,8 +21,14 @@ parseJSONVia = flip go
|
||||
BoolCodec -> parseJSON value
|
||||
StringCodec -> parseJSON value
|
||||
NumberCodec -> parseJSON value
|
||||
ArrayCodec c -> withArray "TODO" (\a -> toList <$> mapM (`go` c) a) value
|
||||
ObjectCodec c -> withObject "TODO" (\o -> goObject o c) value
|
||||
BimapCodec f _ c -> f <$> go value c
|
||||
EitherCodec f _ c -> do
|
||||
old <- go value c
|
||||
case f old of
|
||||
Left err -> fail err -- TODO better error message location?
|
||||
Right new -> pure new
|
||||
SelectCodec c1 c2 -> (Left <$> go value c1) <|> (Right <$> go value c2)
|
||||
|
||||
goObject :: JSON.Object -> ObjectCodec void a -> JSON.Parser a
|
||||
|
@ -23,6 +23,7 @@ data JSONSchema
|
||||
| BoolSchema
|
||||
| StringSchema
|
||||
| NumberSchema
|
||||
| ArraySchema JSONSchema
|
||||
| ObjectSchema !JSONObjectSchema
|
||||
| ChoiceSchema ![JSONSchema]
|
||||
deriving (Show, Eq, Generic)
|
||||
@ -40,7 +41,7 @@ instance ToJSON JSONSchema where
|
||||
BoolSchema -> JSON.object ["type" JSON..= ("boolean" :: Text)]
|
||||
StringSchema -> JSON.object ["type" JSON..= ("string" :: Text)]
|
||||
NumberSchema -> JSON.object ["type" JSON..= ("number" :: Text)]
|
||||
ChoiceSchema jcs -> JSON.object ["anyOf" JSON..= jcs]
|
||||
ArraySchema s -> JSON.object ["type" JSON..= ("array" :: Text), "items" JSON..= s]
|
||||
ObjectSchema os ->
|
||||
let go = \case
|
||||
AnyObjectSchema -> ([], [])
|
||||
@ -62,6 +63,7 @@ instance ToJSON JSONSchema where
|
||||
"properties" JSON..= ps,
|
||||
"required" JSON..= rps
|
||||
]
|
||||
ChoiceSchema jcs -> JSON.object ["anyOf" JSON..= jcs]
|
||||
|
||||
instance FromJSON JSONSchema where
|
||||
parseJSON = JSON.withObject "JSONSchema" $ \o -> do
|
||||
@ -105,9 +107,11 @@ jsonSchemaVia = go
|
||||
BoolCodec -> BoolSchema
|
||||
StringCodec -> StringSchema
|
||||
NumberCodec -> NumberSchema
|
||||
ArrayCodec c -> ArraySchema (go c)
|
||||
ObjectCodec oc -> ObjectSchema (goObject oc)
|
||||
BimapCodec _ _ c -> go c
|
||||
SelectCodec c1 c2 -> ChoiceSchema [go c1, go c2]
|
||||
EitherCodec _ _ c -> go c
|
||||
|
||||
goObject :: ObjectCodec input output -> JSONObjectSchema
|
||||
goObject = \case
|
||||
|
@ -21,8 +21,10 @@ toJSONVia = flip go
|
||||
BoolCodec -> toJSON (a :: Bool)
|
||||
StringCodec -> toJSON (a :: Text)
|
||||
NumberCodec -> toJSON (a :: Scientific)
|
||||
ArrayCodec c -> toJSON (map (`go` c) a)
|
||||
ObjectCodec oc -> JSON.Object (goObject a oc)
|
||||
BimapCodec _ g c -> go (g a) c
|
||||
EitherCodec _ g c -> go (g a) c
|
||||
SelectCodec c1 c2 -> case a of
|
||||
Left a1 -> go a1 c1
|
||||
Right a2 -> go a2 c2
|
||||
|
@ -22,7 +22,9 @@ import Test.Syd.Validity.Utils
|
||||
spec :: Spec
|
||||
spec = do
|
||||
jsonSchemaSpec @Bool "bool"
|
||||
jsonSchemaSpec @Char "char"
|
||||
jsonSchemaSpec @Text "text"
|
||||
jsonSchemaSpec @String "string"
|
||||
jsonSchemaSpec @Scientific "scientific"
|
||||
jsonSchemaSpec @(Either Bool Text) "either-bool-text"
|
||||
jsonSchemaSpec @(Either (Either Bool Scientific) Text) "either-either-bool-scientific-text"
|
||||
|
@ -12,6 +12,7 @@ import Autodocodec.Aeson
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Types as JSON
|
||||
import Data.Data
|
||||
import Data.GenValidity
|
||||
import Data.GenValidity.Scientific ()
|
||||
import Data.GenValidity.Text ()
|
||||
@ -20,10 +21,14 @@ import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
import Test.Syd
|
||||
import Test.Syd.Validity
|
||||
import Test.Syd.Validity.Utils
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
aesonCodecSpec @Bool
|
||||
-- Does not hold
|
||||
-- aesonCodecSpec @Char
|
||||
-- aesonCodecSpec @String
|
||||
aesonCodecSpec @Text
|
||||
aesonCodecSpec @Scientific
|
||||
aesonCodecSpec @(Either Text Bool)
|
||||
@ -61,7 +66,7 @@ instance FromJSON Example where
|
||||
<$> o JSON..: "text"
|
||||
<*> o JSON..: "bool"
|
||||
|
||||
aesonCodecSpec :: forall a. (Show a, Eq a, GenValid a, ToJSON a, FromJSON a, HasCodec a) => Spec
|
||||
aesonCodecSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, ToJSON a, FromJSON a, HasCodec a) => Spec
|
||||
aesonCodecSpec = do
|
||||
it "matches the aeson encoding" $
|
||||
forAllValid $ \(a :: a) ->
|
||||
@ -72,9 +77,9 @@ aesonCodecSpec = do
|
||||
in JSON.parseEither (parseJSONViaCodec @a) encoded `shouldBe` JSON.parseEither (parseJSON @a) encoded
|
||||
codecSpec @a
|
||||
|
||||
codecSpec :: forall a. (Show a, Eq a, GenValid a, ToJSON a, HasCodec a) => Spec
|
||||
codecSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, ToJSON a, HasCodec a) => Spec
|
||||
codecSpec = do
|
||||
it "roundtrips" $
|
||||
it (nameOf @a <> " roundtrips") $
|
||||
forAllValid $ \(a :: a) ->
|
||||
let encoded = toJSONViaCodec a
|
||||
errOrDecoded = JSON.parseEither parseJSONViaCodec encoded
|
||||
|
3
autodocodec-aeson/test_resources/schema/char.json
Normal file
3
autodocodec-aeson/test_resources/schema/char.json
Normal file
@ -0,0 +1,3 @@
|
||||
{
|
||||
"type": "string"
|
||||
}
|
3
autodocodec-aeson/test_resources/schema/string.json
Normal file
3
autodocodec-aeson/test_resources/schema/string.json
Normal file
@ -0,0 +1,3 @@
|
||||
{
|
||||
"type": "string"
|
||||
}
|
@ -1,21 +1,45 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Autodocodec.Class where
|
||||
|
||||
import Autodocodec.Codec
|
||||
import Data.Int
|
||||
import Data.Scientific
|
||||
import Data.Text (Text)
|
||||
import Data.Word
|
||||
|
||||
class HasCodec a where
|
||||
-- | A codec for a single value
|
||||
--
|
||||
-- See the sections on helper functions for implementing this for plenty of examples.
|
||||
codec :: Codec a a
|
||||
|
||||
-- | A codec for a list of values
|
||||
--
|
||||
-- This is really only useful for cases like 'Char' and 'String'
|
||||
listCodec :: Codec [a] [a]
|
||||
listCodec = ArrayCodec codec
|
||||
|
||||
field :: HasCodec output => Text -> ObjectCodec output output
|
||||
field k = KeyCodec k codec
|
||||
|
||||
instance HasCodec Bool where
|
||||
codec = boolCodec
|
||||
|
||||
instance HasCodec Char where
|
||||
codec =
|
||||
let parseChar = \case
|
||||
[] -> Left "Expected exactly 1 character, but got none."
|
||||
[c] -> Right c
|
||||
_ -> Left "Expected exactly 1 character, but got more."
|
||||
in EitherCodec parseChar (: []) stringCodec
|
||||
listCodec = stringCodec
|
||||
|
||||
instance HasCodec String where
|
||||
codec = listCodec
|
||||
|
||||
instance HasCodec Text where
|
||||
codec = textCodec
|
||||
|
||||
|
@ -10,12 +10,15 @@ import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Scientific
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
data Codec input output where
|
||||
NullCodec :: Codec () ()
|
||||
BoolCodec :: Codec Bool Bool
|
||||
StringCodec :: Codec Text Text
|
||||
NumberCodec :: Codec Scientific Scientific -- TODO can we do this without scientific?
|
||||
-- TODO use a vector here because that's what aeson uses.
|
||||
ArrayCodec :: Codec input output -> Codec [input] [output]
|
||||
ObjectCodec ::
|
||||
ObjectCodec value value ->
|
||||
Codec value value
|
||||
@ -26,6 +29,13 @@ data Codec input output where
|
||||
Codec oldInput oldOutput ->
|
||||
Codec newInput newOutput
|
||||
SelectCodec :: Codec input1 output1 -> Codec input2 output2 -> Codec (Either input1 input2) (Either output1 output2)
|
||||
-- For parsing with potential errors
|
||||
-- TODO: maybe we want to get rid of bimap and implement it in terms of this?
|
||||
EitherCodec ::
|
||||
(oldOutput -> Either String newOutput) ->
|
||||
(newInput -> oldInput) ->
|
||||
Codec oldInput oldOutput ->
|
||||
Codec newInput newOutput
|
||||
|
||||
choiceCodec :: NonEmpty (Codec input output) -> Codec input output
|
||||
choiceCodec (c1 :| rest) = case NE.nonEmpty rest of
|
||||
@ -89,6 +99,9 @@ boolCodec = BoolCodec
|
||||
textCodec :: Codec Text Text
|
||||
textCodec = StringCodec
|
||||
|
||||
stringCodec :: Codec String String
|
||||
stringCodec = BimapCodec T.unpack T.pack StringCodec
|
||||
|
||||
scientificCodec :: Codec Scientific Scientific
|
||||
scientificCodec = NumberCodec
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user