diff --git a/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs b/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs index a95d647..bc78949 100644 --- a/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs +++ b/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs @@ -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 diff --git a/autodocodec-aeson/test/Autodocodec/Aeson/DocumentSpec.hs b/autodocodec-aeson/test/Autodocodec/Aeson/DocumentSpec.hs index f6d9c0b..34b6cb2 100644 --- a/autodocodec-aeson/test/Autodocodec/Aeson/DocumentSpec.hs +++ b/autodocodec-aeson/test/Autodocodec/Aeson/DocumentSpec.hs @@ -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 diff --git a/autodocodec-aeson/test_resources/schema/example.json b/autodocodec-aeson/test_resources/schema/example.json index a27727c..3b2ca27 100644 --- a/autodocodec-aeson/test_resources/schema/example.json +++ b/autodocodec-aeson/test_resources/schema/example.json @@ -1,10 +1,10 @@ { "$comment": "Example", "required": [ - "text", "bool", + "fruit", "maybe", - "fruit" + "text" ], "type": "object", "properties": { diff --git a/autodocodec-yaml/src/Autodocodec/Yaml/Document.hs b/autodocodec-yaml/src/Autodocodec/Yaml/Document.hs index 735460e..bda9c08 100644 --- a/autodocodec-yaml/src/Autodocodec/Yaml/Document.hs +++ b/autodocodec-yaml/src/Autodocodec/Yaml/Document.hs @@ -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 [[""]] - 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 diff --git a/autodocodec-yaml/test_resources/schema/example.txt b/autodocodec-yaml/test_resources/schema/example.txt index 6064b9a..bfd644e 100644 --- a/autodocodec-yaml/test_resources/schema/example.txt +++ b/autodocodec-yaml/test_resources/schema/example.txt @@ -1,6 +1,14 @@ # Example +text: # required +  bool: # required  +maybe: # required + [ null + ,  + ] +optional: # optional +  fruit: # required [ Apple @@ -11,11 +19,3 @@ , Melon ] -maybe: # required - [ null - ,  - ] -optional: # optional -  -text: # required -