autodocodec-schema 0.0.0.0 → 0.1.0.0
raw patch · 3 files changed
+109/−54 lines, 3 filesdep ~autodocodec
Dependency ranges changed: autodocodec
Files
- CHANGELOG.md +10/−0
- autodocodec-schema.cabal +3/−3
- src/Autodocodec/Schema.hs +96/−51
CHANGELOG.md view
@@ -1,5 +1,15 @@ # Changelog +## [0.1.0.0] - 2021-12-21++### Added++* Support for `autodocodec-0.0.1.0`.++### Changed++* `ChoiceSchema` has been split into `OneOfSchema` and `AnyOfSchema`+ ## [0.0.0.0] - 2021-11-19 First release.
autodocodec-schema.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.34.5. -- -- see: https://github.com/sol/hpack name: autodocodec-schema-version: 0.0.0.0+version: 0.1.0.0 synopsis: Autodocodec interpreters for JSON Schema homepage: https://github.com/NorfairKing/autodocodec#readme bug-reports: https://github.com/NorfairKing/autodocodec/issues@@ -32,7 +32,7 @@ src build-depends: aeson- , autodocodec+ , autodocodec >=0.0.1.0 , base >=4.7 && <5 , containers , mtl
src/Autodocodec/Schema.hs view
@@ -48,7 +48,8 @@ | -- | This needs to be a list because keys should stay in their original ordering. ObjectSchema ObjectSchema | ValueSchema !JSON.Value- | ChoiceSchema !(NonEmpty JSONSchema)+ | AnyOfSchema !(NonEmpty JSONSchema)+ | OneOfSchema !(NonEmpty JSONSchema) | CommentSchema !Text !JSONSchema | RefSchema !Text | WithDefSchema !(Map Text JSONSchema) !JSONSchema@@ -62,7 +63,8 @@ CommentSchema _ (CommentSchema _ _) -> False _ -> True, case js of- ChoiceSchema cs -> declare "there are 2 of more choices" $ length cs >= 2+ AnyOfSchema cs -> declare "there are 2 of more choices" $ length cs >= 2+ OneOfSchema cs -> declare "there are 2 of more choices" $ length cs >= 2 _ -> valid ] @@ -90,12 +92,18 @@ case toJSON os of JSON.Object o -> HM.toList o _ -> [] -- Should not happen.- ChoiceSchema jcs ->+ AnyOfSchema jcs -> let svals :: [JSON.Value] svals = map (JSON.object . go) (NE.toList jcs) val :: JSON.Value val = (JSON.toJSON :: [JSON.Value] -> JSON.Value) svals in [("anyOf", val)]+ OneOfSchema jcs ->+ let svals :: [JSON.Value]+ svals = map (JSON.object . go) (NE.toList jcs)+ val :: JSON.Value+ val = (JSON.toJSON :: [JSON.Value] -> JSON.Value) svals+ in [("oneOf", val)] (CommentSchema outerComment (CommentSchema innerComment s)) -> go (CommentSchema (outerComment <> "\n" <> innerComment) s) CommentSchema comment s -> ("$comment" JSON..= comment) : go s@@ -133,25 +141,30 @@ Nothing -> do mAny <- o JSON..:? "anyOf" case mAny of- Just anies -> pure $ ChoiceSchema anies+ Just anies -> pure $ AnyOfSchema anies Nothing -> do- let mConst = HM.lookup "const" o- case mConst of- Just constant -> pure $ ValueSchema constant+ mOne <- o JSON..:? "oneOf"+ case mOne of+ Just ones -> pure $ OneOfSchema ones Nothing -> do- mRef <- o JSON..:? "$ref"- pure $ case mRef of- Just ref -> case T.stripPrefix defsPrefix ref of- Just name -> RefSchema name- Nothing -> AnySchema- Nothing -> AnySchema+ let mConst = HM.lookup "const" o+ case mConst of+ Just constant -> pure $ ValueSchema constant+ Nothing -> do+ mRef <- o JSON..:? "$ref"+ pure $ case mRef of+ Just ref -> case T.stripPrefix defsPrefix ref of+ Just name -> RefSchema name+ Nothing -> AnySchema+ Nothing -> AnySchema t -> fail $ "unknown schema type:" <> show t data ObjectSchema- = ObjectKeySchema Text KeyRequirement JSONSchema (Maybe Text)+ = ObjectKeySchema !Text !KeyRequirement !JSONSchema !(Maybe Text) | ObjectAnySchema -- For 'pure'- | ObjectChoiceSchema (NonEmpty ObjectSchema)- | ObjectAllOfSchema (NonEmpty ObjectSchema)+ | ObjectAnyOfSchema !(NonEmpty ObjectSchema)+ | ObjectOneOfSchema !(NonEmpty ObjectSchema)+ | ObjectAllOfSchema !(NonEmpty ObjectSchema) deriving (Show, Eq, Generic) instance Validity ObjectSchema@@ -171,26 +184,32 @@ Nothing -> do mAnyOf <- o JSON..:? "anyOf" case mAnyOf of- Just ao -> do- ne <- parseJSON ao- ObjectChoiceSchema <$> mapM go ne+ Just anies -> do+ ne <- parseJSON anies+ ObjectAnyOfSchema <$> mapM go ne Nothing -> do- props <- o JSON..:? "properties" JSON..!= HM.empty- reqs <- o JSON..:? "required" JSON..!= []- let keySchemaFor k v = do- ks <- parseJSON v- let (mDoc, ks') = case ks of- CommentSchema doc ks'' -> (Just doc, ks'')- _ -> (Nothing, ks)- pure $- if k `elem` reqs- then ObjectKeySchema k Required ks' mDoc- else ObjectKeySchema k (Optional Nothing) ks' mDoc- keySchemas <- mapM (uncurry keySchemaFor) (HM.toList props)- pure $ case NE.nonEmpty keySchemas of- Nothing -> ObjectAnySchema- Just (el :| []) -> el- Just ne -> ObjectAllOfSchema ne+ mOneOf <- o JSON..:? "oneOf"+ case mOneOf of+ Just ones -> do+ ne <- parseJSON ones+ ObjectOneOfSchema <$> mapM go ne+ Nothing -> do+ props <- o JSON..:? "properties" JSON..!= HM.empty+ reqs <- o JSON..:? "required" JSON..!= []+ let keySchemaFor k v = do+ ks <- parseJSON v+ let (mDoc, ks') = case ks of+ CommentSchema doc ks'' -> (Just doc, ks'')+ _ -> (Nothing, ks)+ pure $+ if k `elem` reqs+ then ObjectKeySchema k Required ks' mDoc+ else ObjectKeySchema k (Optional Nothing) ks' mDoc+ keySchemas <- mapM (uncurry keySchemaFor) (HM.toList props)+ pure $ case NE.nonEmpty keySchemas of+ Nothing -> ObjectAnySchema+ Just (el :| []) -> el+ Just ne -> ObjectAllOfSchema ne instance ToJSON ObjectSchema where toJSON = JSON.object . (("type" JSON..= ("object" :: Text)) :) . go@@ -202,7 +221,8 @@ let (propVal, req) = keySchemaToPieces (k, kr, ks, mDoc) in -- TODO deal with the default value somehow. concat [["properties" JSON..= JSON.object [k JSON..= propVal]], ["required" JSON..= [k] | req]]- ObjectChoiceSchema ne -> ["anyOf" JSON..= NE.map toJSON ne]+ ObjectAnyOfSchema ne -> ["anyOf" JSON..= NE.map toJSON ne]+ ObjectOneOfSchema ne -> ["oneOf" JSON..= NE.map toJSON ne] ObjectAllOfSchema ne -> case mapM parseAndObjectKeySchema (NE.toList ne) of Nothing -> ["allOf" JSON..= NE.map toJSON ne]@@ -239,7 +259,8 @@ Optional _ -> pure True Just value' -> go value' ks ObjectAllOfSchema ne -> and <$> mapM (goObject obj) ne- ObjectChoiceSchema ne -> or <$> mapM (goObject obj) ne+ ObjectAnyOfSchema ne -> or <$> mapM (goObject obj) ne+ ObjectOneOfSchema ne -> (== 1) . length . NE.filter id <$> mapM (goObject obj) ne go :: JSON.Value -> JSONSchema -> State (Map Text JSONSchema) Bool go value = \case@@ -266,7 +287,8 @@ JSON.Object obj -> goObject obj os _ -> pure False ValueSchema v -> pure $ v == value- ChoiceSchema ss -> or <$> mapM (go value) ss+ AnyOfSchema ss -> or <$> mapM (go value) ss+ OneOfSchema ss -> (== 1) . length . NE.filter id <$> mapM (go value) ss CommentSchema _ s -> go value s RefSchema name -> do mSchema <- gets (M.lookup name)@@ -279,7 +301,7 @@ data KeyRequirement = Required- | Optional (Maybe JSON.Value) -- Default value+ | Optional !(Maybe JSON.Value) -- Default value deriving (Show, Eq, Generic) instance Validity KeyRequirement@@ -306,10 +328,12 @@ MapCodec c -> MapSchema <$> go c ValueCodec -> pure AnySchema EqCodec value c -> pure $ ValueSchema (toJSONVia c value)- EitherCodec c1 c2 -> do+ EitherCodec u c1 c2 -> do s1 <- go c1 s2 <- go c2- pure $ ChoiceSchema (goChoice (s1 :| [s2]))+ pure $ case u of+ DisjointUnion -> OneOfSchema (goOneOf (s1 :| [s2]))+ PossiblyJointUnion -> AnyOfSchema (goAnyOf (s1 :| [s2])) BimapCodec _ _ c -> go c CommentCodec t c -> CommentSchema t <$> go c ReferenceCodec name c -> do@@ -321,15 +345,24 @@ s <- go c pure $ WithDefSchema (M.singleton name s) (RefSchema name) - goChoice :: NonEmpty JSONSchema -> NonEmpty JSONSchema- goChoice (s :| rest) = case NE.nonEmpty rest of+ goAnyOf :: NonEmpty JSONSchema -> NonEmpty JSONSchema+ goAnyOf (s :| rest) = case NE.nonEmpty rest of Nothing -> goSingle s- Just ne -> goSingle s <> goChoice ne+ Just ne -> goSingle s <> goAnyOf ne where goSingle :: JSONSchema -> NonEmpty JSONSchema goSingle = \case- ChoiceSchema ss -> goChoice ss+ AnyOfSchema ss -> goAnyOf ss s' -> s' :| []+ goOneOf :: NonEmpty JSONSchema -> NonEmpty JSONSchema+ goOneOf (s :| rest) = case NE.nonEmpty rest of+ Nothing -> goSingle s+ Just ne -> goSingle s <> goOneOf ne+ where+ goSingle :: JSONSchema -> NonEmpty JSONSchema+ goSingle = \case+ OneOfSchema ss -> goOneOf ss+ s' -> s' :| [] goObject :: ObjectCodec input output -> State (Set Text) ObjectSchema goObject = \case@@ -344,24 +377,36 @@ pure $ ObjectKeySchema k (Optional (Just (toJSONVia c mr))) s mdoc OptionalKeyWithOmittedDefaultCodec k c defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec k c defaultValue mDoc) BimapCodec _ _ c -> goObject c- EitherCodec oc1 oc2 -> do+ EitherCodec u oc1 oc2 -> do os1 <- goObject oc1 os2 <- goObject oc2- pure $ ObjectChoiceSchema (goObjectChoice (os1 :| [os2]))+ pure $ case u of+ DisjointUnion -> ObjectOneOfSchema (goObjectOneOf (os1 :| [os2]))+ PossiblyJointUnion -> ObjectAnyOfSchema (goObjectAnyOf (os1 :| [os2])) PureCodec _ -> pure ObjectAnySchema ApCodec oc1 oc2 -> do os1 <- goObject oc1 os2 <- goObject oc2 pure $ ObjectAllOfSchema (goObjectAllOf (os1 :| [os2])) - goObjectChoice :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema- goObjectChoice (s :| rest) = case NE.nonEmpty rest of+ goObjectAnyOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema+ goObjectAnyOf (s :| rest) = case NE.nonEmpty rest of Nothing -> goSingle s- Just ne -> goSingle s <> goObjectChoice ne+ Just ne -> goSingle s <> goObjectAnyOf ne where goSingle :: ObjectSchema -> NonEmpty ObjectSchema goSingle = \case- ObjectChoiceSchema ss -> goObjectChoice ss+ ObjectAnyOfSchema ss -> goObjectAnyOf ss+ s' -> s' :| []++ goObjectOneOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema+ goObjectOneOf (s :| rest) = case NE.nonEmpty rest of+ Nothing -> goSingle s+ Just ne -> goSingle s <> goObjectOneOf ne+ where+ goSingle :: ObjectSchema -> NonEmpty ObjectSchema+ goSingle = \case+ ObjectOneOfSchema ss -> goObjectOneOf ss s' -> s' :| [] goObjectAllOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema