NorfairKing/autodocodec
1
1
Fork 0
mirror of https://github.com/NorfairKing/autodocodec.git synced 2025-01-07 19:11:31 +03:00
Code Issues Projects Releases Wiki Activity

something is going wrong with numbers

Browse Source
This commit is contained in:
Tom Sydney Kerckhove 2021-10-30 02:32:53 +02:00
parent 78fefa969c
commit 4044263ad3
12 changed files with 128 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
autodocodec-aeson/src/Autodocodec/Aeson/Document.hs
View File

@ -23,6 +23,8 @@ import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import Data.Validity
@ -47,7 +49,44 @@ data JSONSchema
| ChoiceSchema !(NonEmpty JSONSchema)
| CommentSchema !Text !JSONSchema
| ReferenceSchema !Text !JSONSchema
deriving (Show, Eq, Generic)
deriving (Eq, Generic)
instance Show JSONSchema where
show = showJSONSchemaABit
showJSONSchemaABit :: JSONSchema -> String
showJSONSchemaABit = ($ "") . (`evalState` S.empty) . go 0
where
go :: Int -> JSONSchema -> State (Set Text) ShowS
go d = \case
AnySchema -> pure $ showString "AnySchema"
NullSchema -> pure $ showString "NullSchema"
BoolSchema -> pure $ showString "BoolSchema"
StringSchema -> pure $ showString "StringSchema"
NumberSchema -> pure $ showString "NumberSchema"
ArraySchema c -> (\s -> showParen (d > 10) $ showString "ArraySchema " . s) <$> go 11 c
ObjectSchema kss -> do
fs <- forM kss $ \(k, (kr, ks)) -> do
let f1 = showsPrec d k
let f2 = showsPrec d kr
f3 <- go d ks
pure $ f1 . showString " " . f2 . showString " " . f3
let s = appEndo $ mconcat $ map Endo fs
pure $ showParen (d > 10) $ showString "ObjectSchema " . s
ValueSchema v -> pure $ showString "ValueSchema" . showsPrec d v
ChoiceSchema jcs -> do
fs <- mapM (go d) (NE.toList jcs)
let s = appEndo $ mconcat $ map Endo fs
pure $ showParen (d > 10) $ showString "ChoiceSchema " . s
CommentSchema comment c -> (\s -> showParen (d > 10) $ showString "CommentSchema " . showsPrec d comment . showString " " . s) <$> go 11 c
ReferenceSchema name c -> do
alreadySeen <- gets (S.member name)
if alreadySeen
then pure $ showParen (d > 10) $ showString "ReferenceSchema " . showsPrec d name
else do
modify (S.insert name)
s <- go d c
pure $ showParen (d > 10) $ showString "ReferenceSchema " . showsPrec d name . showString " " . s
validateAccordingTo :: JSON.Value -> JSONSchema -> Bool
validateAccordingTo = go

25
autodocodec-api-usage/src/Autodocodec/Usage.hs
View File

@ -17,12 +17,8 @@ import Data.GenValidity
import Data.GenValidity.Aeson ()
import Data.GenValidity.Scientific ()
import Data.GenValidity.Text ()
import Data.Int
import Data.Maybe
import Data.Scientific
import Data.Text (Text)
import qualified Data.Text.Lazy as LT
import Data.Word
import GHC.Generics (Generic)
import Test.QuickCheck
@ -124,13 +120,14 @@ instance FromJSON Recursive where
instance HasCodec Recursive where
codec =
let f = \case
Left i -> Base i
Right r -> Recurse r
g = \case
Base i -> Left i
Recurse r -> Right r
in bimapCodec f g $
eitherCodec
(codec @Int)
(object "Recurse" $ requiredField "recurse")
ReferenceCodec "recursive" $
let f = \case
Left i -> Base i
Right r -> Recurse r
g = \case
Base i -> Left i
Recurse r -> Right r
in bimapCodec f g $
eitherCodec
(codec @Int)
(object "Recurse" $ requiredField "recurse")

1
autodocodec-api-usage/test/Autodocodec/Aeson/DocumentSpec.hs
View File

@ -23,7 +23,6 @@ import Data.Scientific
import Data.Text (Text)
import qualified Data.Text.Lazy as LT
import Data.Word
import GHC.Generics (Generic)
import Test.QuickCheck
import Test.Syd
import Test.Syd.Aeson

16
autodocodec-api-usage/test/Autodocodec/AesonSpec.hs
View File

@ -8,7 +8,6 @@ module Autodocodec.AesonSpec (spec) where
import Autodocodec
import Autodocodec.Aeson
import Autodocodec.Usage
import Control.Applicative
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
@ -18,13 +17,11 @@ import Data.GenValidity.Aeson ()
import Data.GenValidity.Scientific ()
import Data.GenValidity.Text ()
import Data.Int
import Data.Maybe
import Data.Scientific
import Data.Text (Text)
import qualified Data.Text.Lazy as LT
import Data.Word
import GHC.Generics (Generic)
import Test.QuickCheck
import Debug.Trace
import Test.Syd
import Test.Syd.Validity
import Test.Syd.Validity.Utils
@ -56,7 +53,8 @@ spec = do
aesonCodecSpec @[Text]
aesonCodecSpec @Fruit
aesonCodecSpec @Example
aesonCodecSpec @Recursive
-- aesonCodecSpec @Recursive
aesonCodecSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, ToJSON a, FromJSON a, HasCodec a) => Spec
aesonCodecSpec =
@ -71,7 +69,7 @@ aesonCodecSpec =
in context ctx $ toJSONViaCodec a `shouldBe` JSON.toJSON a
it "matches the aeson decoding" $
forAllValid $ \(a :: a) ->
let encoded = JSON.toJSON a
let encoded = traceShowId $ JSON.toJSON $ traceShowId a
ctx =
unlines
[ "Encoded to this value:",
@ -79,7 +77,11 @@ aesonCodecSpec =
"with this codec",
showCodecABit (codec @a)
]
in context ctx $ JSON.parseEither (parseJSONViaCodec @a) encoded `shouldBe` JSON.parseEither (parseJSON @a) encoded
decodedWithAeson = traceShowId $ JSON.parseEither (parseJSON @a) encoded
decodedWithAutodocodec = traceShowId $ JSON.parseEither (parseJSONViaCodec @a) encoded
in trace (showCodecABit (codec @a)) $
context ctx $
decodedWithAutodocodec `shouldBe` decodedWithAeson
codecSpec @a
codecSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, ToJSON a, HasCodec a) => Spec

2
autodocodec-api-usage/test/Autodocodec/Yaml/DocumentSpec.hs
View File

@ -19,8 +19,6 @@ import Data.Scientific
import Data.Text (Text)
import qualified Data.Text.Lazy as LT
import Data.Word
import GHC.Generics (Generic)
import Test.QuickCheck
import Test.Syd
import Test.Syd.Validity.Utils
import Text.Colour

25
autodocodec-api-usage/test_resources/schema/r.json
View File

@ -1,25 +0,0 @@
{
"$ref": "#/$defs/R",
"$defs": {
"R": {
"anyOf": [
{
"$comment": "Int",
"type": "number"
},
{
"$comment": "S",
"required": [
"s"
],
"type": "object",
"properties": {
"s": {
"$ref": "#/$defs/R"
}
}
}
]
}
}
}

7
autodocodec-api-usage/test_resources/schema/r.txt
View File

@ -1,7 +0,0 @@
def: R
[ # Int
<number>
, # S
s: # required
ref: R
]

25
autodocodec-api-usage/test_resources/schema/recursive.json
View File

@ -0,0 +1,25 @@
{
"$ref": "#/$defs/recursive",
"$defs": {
"recursive": {
"anyOf": [
{
"$comment": "Int",
"type": "number"
},
{
"$comment": "Recurse",
"required": [
"recurse"
],
"type": "object",
"properties": {
"recurse": {
"$ref": "#/$defs/recursive"
}
}
}
]
}
}
}

7
autodocodec-api-usage/test_resources/schema/recursive.txt
View File

@ -0,0 +1,7 @@
def: recursive
[ # Int
<number>
, # Recurse
recurse: # required
ref: recursive
]

2
autodocodec/autodocodec.cabal
View File

@ -33,6 +33,8 @@ library
aeson
, base >=4.7 && <5
, bytestring
, containers
, mtl
, scientific
, text
default-language: Haskell2010

2
autodocodec/package.yaml
View File

@ -16,5 +16,7 @@ library:
dependencies:
- aeson
- bytestring
- containers
- mtl
- scientific
- text

53
autodocodec/src/Autodocodec/Codec.hs
View File

@ -6,10 +6,13 @@
module Autodocodec.Codec where
import Control.Monad.State
import Data.Aeson as JSON
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Scientific as Scientific
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
@ -63,30 +66,38 @@ data Codec input output where
-- Jsut for debugging
showCodecABit :: Codec input output -> String
showCodecABit = ($ "") . go 0
showCodecABit = ($ "") . (`evalState` S.empty) . go 0
where
go :: Int -> Codec input output -> ShowS
go :: Int -> Codec input output -> State (Set Text) ShowS
go d = \case
ValueCodec -> showString "ValueCodec"
NullCodec -> showString "NullCodec"
BoolCodec -> showString "BoolCodec"
StringCodec -> showString "StringCodec"
NumberCodec -> showString "NumberCodec"
ArrayCodec name c -> showParen (d > 10) $ showString "ArrayCodec " . showsPrec d name . showString " " . go 11 c
ObjectCodec name oc -> showParen (d > 10) $ showString "ObjectCodec " . showsPrec d name . showString " " . goObject 11 oc
EqCodec value c -> showParen (d > 10) $ showString "EqCodec " . showsPrec d value . showString " " . go 11 c
BimapCodec _ _ c -> showParen (d > 10) $ showString "BimapCodec " . go 11 c
EitherCodec c1 c2 -> showParen (d > 10) $ showString "EitherCodec " . go 11 c1 . showString " " . go 11 c2
ExtraParserCodec _ _ c -> showParen (d > 10) $ showString "ExtraParserCodec " . go 11 c
CommentCodec comment c -> showParen (d > 10) $ showString "CommentCodec " . showsPrec d comment . showString " " . go 11 c
ReferenceCodec comment c -> showParen (d > 10) $ showString "ReferenceCodec " . showsPrec d comment . showString " " . go 11 c
goObject :: Int -> ObjectCodec input output -> ShowS
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
EqCodec value c -> (\s -> showParen (d > 10) $ showString "EqCodec " . showsPrec d 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
ExtraParserCodec _ _ c -> (\s -> showParen (d > 10) $ showString "ExtraParserCodec " . s) <$> go 11 c
CommentCodec comment c -> (\s -> showParen (d > 10) $ showString "CommentCodec " . showsPrec d comment . showString " " . s) <$> go 11 c
ReferenceCodec name c -> do
alreadySeen <- gets (S.member name)
if alreadySeen
then pure $ showParen (d > 10) $ showString "ReferenceCodec " . showsPrec d name
else do
modify (S.insert name)
s <- go d c
pure $ showParen (d > 10) $ showString "ReferenceCodec " . showsPrec d name . showString " " . s
goObject :: Int -> ObjectCodec input output -> State (Set Text) ShowS
goObject d = \case
RequiredKeyCodec k c -> showParen (d > 10) $ showString "RequiredKeyCodec " . showsPrec d k . showString " " . go 11 c
OptionalKeyCodec k c -> showParen (d > 10) $ showString "OptionalKeyCodec " . showsPrec d k . showString " " . go 11 c
PureObjectCodec _ -> showString "PureObjectCodec" -- TODO add show instance?
BimapObjectCodec _ _ oc -> showParen (d > 10) $ showString "BimapObjectCodec " . goObject 11 oc
ApObjectCodec oc1 oc2 -> showParen (d > 10) $ showString "KeyCodec " . goObject 11 oc1 . showString " " . goObject 11 oc2
RequiredKeyCodec k c -> (\s -> showParen (d > 10) $ showString "RequiredKeyCodec " . showsPrec d k . showString " " . s) <$> go 11 c
OptionalKeyCodec k c -> (\s -> showParen (d > 10) $ showString "OptionalKeyCodec " . showsPrec d k . showString " " . s) <$> go 11 c
PureObjectCodec _ -> pure $ showString "PureObjectCodec" -- TODO add show instance?
BimapObjectCodec _ _ oc -> (\s -> showParen (d > 10) $ showString "BimapObjectCodec " . s) <$> goObject 11 oc
ApObjectCodec oc1 oc2 -> (\s1 s2 -> showParen (d > 10) $ showString "KeyCodec " . s1 . showString " " . s2) <$> goObject 11 oc1 <*> goObject 11 oc2
fmapCodec :: (oldOutput -> newOutput) -> Codec input oldOutput -> Codec input newOutput
fmapCodec f = BimapCodec f id