mirror of
https://github.com/NorfairKing/autodocodec.git
synced 2024-10-27 16:20:04 +03:00
Ordered keys
This commit is contained in:
parent
c64f52dbce
commit
cbe01f0db5
@ -12,12 +12,15 @@ import Autodocodec
|
||||
import Autodocodec.Aeson.Encode
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as JSON
|
||||
import Data.Foldable
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.List
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import Data.Validity
|
||||
import Data.Validity.Aeson ()
|
||||
@ -35,7 +38,8 @@ data JSONSchema
|
||||
| StringSchema
|
||||
| NumberSchema
|
||||
| ArraySchema !JSONSchema
|
||||
| ObjectSchema !(Map Text (KeyRequirement, JSONSchema)) -- TODO it's important (for docs) that these stay ordered.
|
||||
| -- | This needs to be a list because keys should stay in their original ordering.
|
||||
ObjectSchema ![(Text, (KeyRequirement, JSONSchema))]
|
||||
| ValueSchema !JSON.Value
|
||||
| ChoiceSchema !(NonEmpty JSONSchema)
|
||||
| CommentSchema !Text !JSONSchema
|
||||
@ -49,6 +53,10 @@ instance Validity JSONSchema where
|
||||
CommentSchema _ (CommentSchema _ _) -> False
|
||||
_ -> True,
|
||||
case js of
|
||||
ObjectSchema ks ->
|
||||
declare "there are no two equal keys in a keys schema" $
|
||||
let l = map fst ks
|
||||
in nub l == l
|
||||
ChoiceSchema cs -> declare "there are 2 of more choices" $ length cs >= 2
|
||||
_ -> valid
|
||||
]
|
||||
@ -70,23 +78,26 @@ instance ToJSON JSONSchema where
|
||||
ArraySchema s -> ["type" JSON..= ("array" :: Text), "items" JSON..= s]
|
||||
ValueSchema v -> ["const" JSON..= v]
|
||||
ObjectSchema os ->
|
||||
let combine (ps, rps) k (r, s) =
|
||||
let combine (ps, rps) (k, (r, s)) =
|
||||
( (k, s) : ps,
|
||||
case r of
|
||||
Required -> k : rps
|
||||
Required -> S.insert k rps
|
||||
Optional -> rps
|
||||
)
|
||||
in case M.foldlWithKey combine ([], []) os of
|
||||
([], _) -> ["type" JSON..= ("object" :: Text)]
|
||||
(ps, []) ->
|
||||
[ "type" JSON..= ("object" :: Text),
|
||||
"properties" JSON..= HM.fromList ps
|
||||
]
|
||||
(ps, rps) ->
|
||||
[ "type" JSON..= ("object" :: Text),
|
||||
"properties" JSON..= HM.fromList ps,
|
||||
"required" JSON..= rps
|
||||
]
|
||||
(props, requiredProps) = foldl' combine ([], S.empty) os
|
||||
in case props of
|
||||
[] -> ["type" JSON..= ("object" :: Text)]
|
||||
_ ->
|
||||
if S.null requiredProps
|
||||
then
|
||||
[ "type" JSON..= ("object" :: Text),
|
||||
"properties" JSON..= HM.fromList props
|
||||
]
|
||||
else
|
||||
[ "type" JSON..= ("object" :: Text),
|
||||
"properties" JSON..= HM.fromList props,
|
||||
"required" JSON..= requiredProps
|
||||
]
|
||||
ChoiceSchema jcs -> ["anyOf" JSON..= jcs]
|
||||
CommentSchema comment s -> ("$comment" JSON..= comment) : go s -- TODO this is probably wrong.
|
||||
|
||||
@ -108,18 +119,18 @@ instance FromJSON JSONSchema where
|
||||
Just "object" -> do
|
||||
mP <- o JSON..:? "properties"
|
||||
case mP of
|
||||
Nothing -> pure $ ObjectSchema M.empty
|
||||
Nothing -> pure $ ObjectSchema []
|
||||
Just (props :: Map Text JSONSchema) -> do
|
||||
requiredProps <- fromMaybe [] <$> o JSON..:? "required"
|
||||
let keySchemaFor k s =
|
||||
M.singleton
|
||||
k
|
||||
( k,
|
||||
( if k `elem` requiredProps
|
||||
then Required
|
||||
else Optional,
|
||||
s
|
||||
)
|
||||
pure $ ObjectSchema $ M.unions $ map (uncurry keySchemaFor) $ M.toList props
|
||||
)
|
||||
pure $ ObjectSchema $ map (uncurry keySchemaFor) $ M.toList props
|
||||
Nothing -> do
|
||||
mAny <- o JSON..:? "anyOf"
|
||||
case mAny of
|
||||
@ -161,10 +172,10 @@ jsonSchemaVia = go
|
||||
ChoiceSchema ss -> goChoice ss
|
||||
s' -> s' :| []
|
||||
|
||||
goObject :: ObjectCodec input output -> Map Text (KeyRequirement, JSONSchema)
|
||||
goObject :: ObjectCodec input output -> [(Text, (KeyRequirement, JSONSchema))]
|
||||
goObject = \case
|
||||
RequiredKeyCodec k c -> M.singleton k (Required, go c)
|
||||
OptionalKeyCodec k c -> M.singleton k (Optional, go c)
|
||||
RequiredKeyCodec k c -> [(k, (Required, go c))]
|
||||
OptionalKeyCodec k c -> [(k, (Optional, go c))]
|
||||
BimapObjectCodec _ _ oc -> goObject oc
|
||||
PureObjectCodec _ -> M.empty
|
||||
ApObjectCodec oc1 oc2 -> M.union (goObject oc1) (goObject oc2)
|
||||
PureObjectCodec _ -> []
|
||||
ApObjectCodec oc1 oc2 -> goObject oc1 ++ goObject oc2
|
||||
|
@ -10,6 +10,7 @@ module Autodocodec.Aeson.DocumentSpec (spec) where
|
||||
|
||||
import Autodocodec
|
||||
import Autodocodec.Aeson
|
||||
import qualified Data.Aeson as JSON
|
||||
import Data.Data
|
||||
import Data.GenValidity
|
||||
import Data.GenValidity.Aeson ()
|
||||
@ -27,7 +28,6 @@ import Test.QuickCheck
|
||||
import Test.Syd
|
||||
import Test.Syd.Aeson
|
||||
import Test.Syd.Validity
|
||||
import Test.Syd.Validity.Aeson
|
||||
import Test.Syd.Validity.Utils
|
||||
|
||||
spec :: Spec
|
||||
@ -56,7 +56,15 @@ spec = do
|
||||
jsonSchemaSpec @Example "example"
|
||||
describe "JSONSchema" $ do
|
||||
genValidSpec @JSONSchema
|
||||
jsonSpecOnValid @JSONSchema
|
||||
it "roundtrips through json and back" $
|
||||
forAllValid $ \jsonSchema ->
|
||||
-- We use the reencode version to survive the ordering change through map
|
||||
let encoded = JSON.encode (jsonSchema :: JSONSchema)
|
||||
in case JSON.eitherDecode encoded of
|
||||
Left err -> expectationFailure err
|
||||
Right decoded ->
|
||||
let encodedAgain = JSON.encode (decoded :: JSONSchema)
|
||||
in encodedAgain `shouldBe` encoded
|
||||
|
||||
instance GenValid JSONSchema where
|
||||
shrinkValid = \case
|
||||
@ -66,7 +74,7 @@ instance GenValid JSONSchema where
|
||||
StringSchema -> [AnySchema]
|
||||
NumberSchema -> [AnySchema]
|
||||
ArraySchema s -> s : (ArraySchema <$> shrinkValid s)
|
||||
ObjectSchema os -> ObjectSchema <$> shrinkValid os
|
||||
ObjectSchema os -> filter isValid $ ObjectSchema <$> shrinkValid os
|
||||
ValueSchema v -> ValueSchema <$> shrinkValid v
|
||||
ChoiceSchema ss -> case ss of
|
||||
s :| [] -> [s]
|
||||
@ -80,7 +88,7 @@ instance GenValid JSONSchema where
|
||||
else
|
||||
oneof
|
||||
[ ArraySchema <$> resize (n -1) genValid,
|
||||
ObjectSchema <$> resize (n -1) genValid,
|
||||
(ObjectSchema <$> resize (n -1) genValid) `suchThat` isValid,
|
||||
do
|
||||
(a, b, c) <- genSplit3 (n -1)
|
||||
choice1 <- resize a genValid
|
||||
|
@ -1,10 +1,10 @@
|
||||
{
|
||||
"$comment": "Example",
|
||||
"required": [
|
||||
"text",
|
||||
"bool",
|
||||
"fruit",
|
||||
"maybe",
|
||||
"fruit"
|
||||
"text"
|
||||
],
|
||||
"type": "object",
|
||||
"properties": {
|
||||
|
@ -9,7 +9,6 @@ module Autodocodec.Yaml.Document where
|
||||
import Autodocodec
|
||||
import Autodocodec.Aeson
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Text.Encoding.Error as TE
|
||||
import Data.Yaml as Yaml
|
||||
@ -47,9 +46,9 @@ jsonSchemaChunks = concatMap (\l -> l ++ ["\n"]) . go
|
||||
Required -> fore red "required"
|
||||
Optional -> fore blue "optional"
|
||||
keySchemaFor k (kr, ks) = addInFrontOfFirstInList [fore white $ chunk k, ":", " "] (["# ", requirementComment kr] : go ks)
|
||||
in if M.null s
|
||||
in if null s
|
||||
then [["<object>"]]
|
||||
else concatMap (uncurry keySchemaFor) (M.toList s)
|
||||
else concatMap (uncurry keySchemaFor) s
|
||||
ValueSchema v -> [[chunk $ TE.decodeUtf8With TE.lenientDecode (Yaml.encode v)]]
|
||||
ChoiceSchema s ->
|
||||
let addListAround = \case
|
||||
|
@ -1,6 +1,14 @@
|
||||
# Example
|
||||
[37mtext[m: # [31mrequired[m
|
||||
[33m<string>[m
|
||||
[37mbool[m: # [31mrequired[m
|
||||
[33m<boolean>[m
|
||||
[37mmaybe[m: # [31mrequired[m
|
||||
[ [33mnull[m
|
||||
, [33m<string>[m
|
||||
]
|
||||
[37moptional[m: # [34moptional[m
|
||||
[33m<string>[m
|
||||
[37mfruit[m: # [31mrequired[m
|
||||
[ Apple
|
||||
|
||||
@ -11,11 +19,3 @@
|
||||
, Melon
|
||||
|
||||
]
|
||||
[37mmaybe[m: # [31mrequired[m
|
||||
[ [33mnull[m
|
||||
, [33m<string>[m
|
||||
]
|
||||
[37moptional[m: # [34moptional[m
|
||||
[33m<string>[m
|
||||
[37mtext[m: # [31mrequired[m
|
||||
[33m<string>[m
|
||||
|
Loading…
Reference in New Issue
Block a user