autodocodec-yaml 0.4.0.0 → 0.4.0.1

raw patch · 3 files changed

+135/−78 lines, 3 filesdep ~autodocodec-schemaPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: autodocodec-schema

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−0
• autodocodec-yaml.cabal +3/−3
• src/Autodocodec/Yaml/Schema.hs +115/−75

@@ -1,5 +1,22 @@ # Changelog +## [0.4.0.1] - 2025-02-13++### Added++* `renderColouredObjectSchemaViaCodec`+* `renderColouredObjectSchemaVia`+* `renderPlainObjectSchemaViaCodec`+* `renderPlainObjectSchemaVia`+* `objectSchemaChunksViaCodec`+* `objectSchemaChunksVia`+* `jsonObjectSchemaChunks`+* `jsonObjectSchemaChunkLines`++### Changed++* Support for `autodocodec-schema >=0.2.0.1`+ ## [0.4.0.0] - 2024-08-03  ### Changed

@@ -5,13 +5,13 @@ -- see: https://github.com/sol/hpack  name:           autodocodec-yaml-version:        0.4.0.0+version:        0.4.0.1 synopsis:       Autodocodec interpreters for yaml homepage:       https://github.com/NorfairKing/autodocodec#readme bug-reports:    https://github.com/NorfairKing/autodocodec/issues author:         Tom Sydney Kerckhove maintainer:     syd@cs-syd.eu-copyright:      2021-2023 Tom Sydney Kerckhove+copyright:      2021-2025 Tom Sydney Kerckhove license:        MIT license-file:   LICENSE build-type:     Simple@@ -35,7 +35,7 @@       src   build-depends:       autodocodec >=0.4.0.0-    , autodocodec-schema >=0.1.0.5+    , autodocodec-schema >=0.2.0.1     , base >=4.7 && <5     , bytestring     , containers

@@ -7,12 +7,20 @@ module Autodocodec.Yaml.Schema   ( renderColouredSchemaViaCodec,     renderColouredSchemaVia,+    renderColouredObjectSchemaViaCodec,+    renderColouredObjectSchemaVia,     renderPlainSchemaViaCodec,     renderPlainSchemaVia,+    renderPlainObjectSchemaViaCodec,+    renderPlainObjectSchemaVia,     schemaChunksViaCodec,+    objectSchemaChunksViaCodec,     schemaChunksVia,+    objectSchemaChunksVia,     jsonSchemaChunks,+    jsonObjectSchemaChunks,     jsonSchemaChunkLines,+    jsonObjectSchemaChunkLines,   ) where @@ -32,117 +40,126 @@ renderColouredSchemaViaCodec :: forall a. (HasCodec a) => Text renderColouredSchemaViaCodec = renderColouredSchemaVia (codec @a) +-- | Render a human-readable schema for a type's 'objectCodec', in colour.+renderColouredObjectSchemaViaCodec :: forall a. (HasObjectCodec a) => Text+renderColouredObjectSchemaViaCodec = renderColouredObjectSchemaVia (objectCodec @a)+ -- | Render a human-readable schema for a given codec, in colour. renderColouredSchemaVia :: ValueCodec input output -> Text renderColouredSchemaVia = renderChunksText With24BitColours . schemaChunksVia +-- | Render a human-readable schema for a given object codec, in colour.+renderColouredObjectSchemaVia :: ObjectCodec input output -> Text+renderColouredObjectSchemaVia = renderChunksText With24BitColours . objectSchemaChunksVia+ -- | Render a human-readable schema for a type's 'codec', without colour. renderPlainSchemaViaCodec :: forall a. (HasCodec a) => Text renderPlainSchemaViaCodec = renderPlainSchemaVia (codec @a) +-- | Render a human-readable schema for a type's 'objectCodec', without colour.+renderPlainObjectSchemaViaCodec :: forall a. (HasObjectCodec a) => Text+renderPlainObjectSchemaViaCodec = renderPlainObjectSchemaVia (objectCodec @a)+ -- | Render a human-readable schema for a given codec, without colour. renderPlainSchemaVia :: ValueCodec input output -> Text renderPlainSchemaVia = renderChunksText WithoutColours . schemaChunksVia +-- | Render a human-readable schema for a given object codec, without colour.+renderPlainObjectSchemaVia :: ObjectCodec input output -> Text+renderPlainObjectSchemaVia = renderChunksText WithoutColours . objectSchemaChunksVia+ -- | Produce potentially-coloured 'Chunk's for a human-readable schema for a type's 'codec'. schemaChunksViaCodec :: forall a. (HasCodec a) => [Chunk] schemaChunksViaCodec = schemaChunksVia (codec @a) +-- | Produce potentially-coloured 'Chunk's for a human-readable schema for a type's 'objectCodec'.+objectSchemaChunksViaCodec :: forall a. (HasObjectCodec a) => [Chunk]+objectSchemaChunksViaCodec = objectSchemaChunksVia (objectCodec @a)+ -- | Produce potentially-coloured 'Chunk's for a human-readable schema for a given codec. schemaChunksVia :: ValueCodec input output -> [Chunk] schemaChunksVia = jsonSchemaChunks . jsonSchemaVia +-- | Produce potentially-coloured 'Chunk's for a human-readable schema for a given object codec.+objectSchemaChunksVia :: ObjectCodec input output -> [Chunk]+objectSchemaChunksVia = jsonObjectSchemaChunks . jsonObjectSchemaVia+ -- | Render a 'JSONSchema' as 'Chunk's jsonSchemaChunks :: JSONSchema -> [Chunk] jsonSchemaChunks = unlinesChunks . jsonSchemaChunkLines +-- | Render an 'ObjectSchema' as 'Chunk's+jsonObjectSchemaChunks :: ObjectSchema -> [Chunk]+jsonObjectSchemaChunks = unlinesChunks . jsonObjectSchemaChunkLines+ -- | Render a 'JSONSchema' as lines of 'Chunk's jsonSchemaChunkLines :: JSONSchema -> [[Chunk]]-jsonSchemaChunkLines = go-  where-    indent :: [[Chunk]] -> [[Chunk]]-    indent = map ("  " :)+jsonSchemaChunkLines = goValue -    addInFrontOfFirstInList :: [Chunk] -> [[Chunk]] -> [[Chunk]]-    addInFrontOfFirstInList cs = \case-      [] -> [cs] -- Shouldn't happen, but fine if it doesn't-      (l : ls) -> (cs ++ l) : indent ls+-- | Render an 'ObjectSchema' as lines of 'Chunk's+jsonObjectSchemaChunkLines :: ObjectSchema -> [[Chunk]]+jsonObjectSchemaChunkLines = goObject -    jsonValueChunks :: Yaml.Value -> [[Chunk]]-    jsonValueChunks v = map ((: []) . chunk) $ T.lines $ T.strip $ TE.decodeUtf8With TE.lenientDecode (Yaml.encode v)+indent :: [[Chunk]] -> [[Chunk]]+indent = map ("  " :) -    docToLines :: Text -> [[Chunk]]-    docToLines doc = map (\line -> [chunk "# ", chunk line]) (T.lines doc)+addInFrontOfFirstInList :: [Chunk] -> [[Chunk]] -> [[Chunk]]+addInFrontOfFirstInList cs = \case+  [] -> [cs] -- Shouldn't happen, but fine if it doesn't+  (l : ls) -> (cs ++ l) : indent ls -    choiceChunks :: NonEmpty [[Chunk]] -> [[Chunk]]-    choiceChunks = \case-      chunks :| [] -> addInFrontOfFirstInList ["[ "] chunks ++ [["]"]]-      (chunks :| restChunks) ->-        concat $-          addInFrontOfFirstInList ["[ "] chunks-            : map (addInFrontOfFirstInList [", "]) restChunks-            ++ [[["]"]]]+jsonValueChunks :: Yaml.Value -> [[Chunk]]+jsonValueChunks v = map ((: []) . chunk) $ T.lines $ T.strip $ TE.decodeUtf8With TE.lenientDecode (Yaml.encode v) -    anyOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]-    anyOfChunks = (["# ", fore green "any of"] :) . choiceChunks+docToLines :: Text -> [[Chunk]]+docToLines doc = map (\line -> [chunk "# ", chunk line]) (T.lines doc) -    oneOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]-    oneOfChunks = (["# ", fore green "one of"] :) . choiceChunks+choiceChunks :: NonEmpty [[Chunk]] -> [[Chunk]]+choiceChunks = \case+  chunks :| [] -> addInFrontOfFirstInList ["[ "] chunks ++ [["]"]]+  (chunks :| restChunks) ->+    concat $+      addInFrontOfFirstInList ["[ "] chunks+        : map (addInFrontOfFirstInList [", "]) restChunks+        ++ [[["]"]]] -    orNullChunks :: JSONSchema -> [[Chunk]]-    orNullChunks = (["# ", fore green "or null"] :) . go+anyOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]+anyOfChunks = (["# ", fore green "any of"] :) . choiceChunks -    go :: JSONSchema -> [[Chunk]]-    go = \case-      AnySchema -> [[fore yellow "<any>"]]-      NullSchema -> [[fore yellow "null"]]-      BoolSchema -> [[fore yellow "<boolean>"]]-      StringSchema -> [[fore yellow "<string>"]]-      IntegerSchema bounds -> integerBoundsChunks bounds-      NumberSchema _ -> [[fore yellow "<number>"]] -- TODO bounds?-      ArraySchema s ->-        let addListMarker = addInFrontOfFirstInList ["- "]-         in addListMarker $ go s-      MapSchema s ->-        addInFrontOfFirstInList [fore white "<key>", ": "] $ [] : go s-      ObjectSchema os -> goObject os-      ValueSchema v -> jsonValueChunks v-      AnyOfSchema ne -> case ne of-        (NullSchema :| [s]) -> orNullChunks s-        (s :| [NullSchema]) -> orNullChunks s-        _ -> anyOfChunks $ NE.map go ne-      OneOfSchema ne -> case ne of-        (NullSchema :| [s]) -> orNullChunks s-        (s :| [NullSchema]) -> orNullChunks s-        _ -> oneOfChunks $ NE.map go ne-      CommentSchema comment s -> docToLines comment ++ go s-      RefSchema name -> [[fore cyan $ chunk $ "ref: " <> name]]-      WithDefSchema defs (RefSchema _) -> concatMap (\(name, s') -> [fore cyan $ chunk $ "def: " <> name] : go s') (M.toList defs)-      WithDefSchema defs s -> concatMap (\(name, s') -> [fore cyan $ chunk $ "def: " <> name] : go s') (M.toList defs) ++ go s+oneOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]+oneOfChunks = (["# ", fore green "one of"] :) . choiceChunks -    goObject :: ObjectSchema -> [[Chunk]]-    goObject = \case-      ObjectAnySchema -> [["<object>"]]-      ObjectKeySchema k kr ks mdoc ->-        let requirementComment = \case-              Required -> fore red "required"-              Optional _ -> fore blue "optional"-            mDefaultValue = \case-              Required -> Nothing-              Optional mdv -> mdv-         in let keySchemaChunks = go ks-                defaultValueLine = case mDefaultValue kr of-                  Nothing -> []-                  Just defaultValue ->-                    case jsonValueChunks defaultValue of-                      [c] -> [chunk "# default: " : map (fore magenta) c]-                      cs -> [chunk "# default: "] : map ((chunk "#   " :) . map (fore magenta)) cs-                prefixLines = ["# ", requirementComment kr] : defaultValueLine ++ maybe [] docToLines mdoc-             in addInFrontOfFirstInList [fore white $ chunk k, ": "] (prefixLines ++ keySchemaChunks)-      ObjectAllOfSchema ne -> concatMap goObject $ NE.toList ne-      ObjectAnyOfSchema ne -> anyOfChunks $ NE.map goObject ne-      ObjectOneOfSchema ne -> oneOfChunks $ NE.map goObject ne+orNullChunks :: JSONSchema -> [[Chunk]]+orNullChunks = (["# ", fore green "or null"] :) . goValue +goValue :: JSONSchema -> [[Chunk]]+goValue = \case+  AnySchema -> [[fore yellow "<any>"]]+  NullSchema -> [[fore yellow "null"]]+  BoolSchema -> [[fore yellow "<boolean>"]]+  StringSchema -> [[fore yellow "<string>"]]+  IntegerSchema bounds -> integerBoundsChunks bounds+  NumberSchema _ -> [[fore yellow "<number>"]] -- TODO bounds?+  ArraySchema s ->+    let addListMarker = addInFrontOfFirstInList ["- "]+     in addListMarker $ goValue s+  MapSchema s ->+    addInFrontOfFirstInList [fore white "<key>", ": "] $ [] : goValue s+  ObjectSchema os -> goObject os+  ValueSchema v -> jsonValueChunks v+  AnyOfSchema ne -> case ne of+    (NullSchema :| [s]) -> orNullChunks s+    (s :| [NullSchema]) -> orNullChunks s+    _ -> anyOfChunks $ NE.map goValue ne+  OneOfSchema ne -> case ne of+    (NullSchema :| [s]) -> orNullChunks s+    (s :| [NullSchema]) -> orNullChunks s+    _ -> oneOfChunks $ NE.map goValue ne+  CommentSchema comment s -> docToLines comment ++ goValue s+  RefSchema name -> [[fore cyan $ chunk $ "ref: " <> name]]+  WithDefSchema defs (RefSchema _) -> concatMap (\(name, s') -> [fore cyan $ chunk $ "def: " <> name] : goValue s') (M.toList defs)+  WithDefSchema defs s -> concatMap (\(name, s') -> [fore cyan $ chunk $ "def: " <> name] : goValue s') (M.toList defs) ++ goValue s+  where     integerBoundsChunks :: Bounds Integer -> [[Chunk]]     integerBoundsChunks nb =       [ fore yellow "<integer>" : case guessIntegerBoundsSymbolic nb of@@ -173,3 +190,26 @@           MinusPowerOf2 w -> chunk $ T.pack $ "-2^" <> show w           MinusPowerOf2MinusOne w -> chunk $ T.pack $ "- (2^" <> show w <> "-1)"           OtherInteger i -> chunk $ T.pack $ show i++goObject :: ObjectSchema -> [[Chunk]]+goObject = \case+  ObjectAnySchema -> [["<object>"]]+  ObjectKeySchema k kr ks mdoc ->+    let requirementComment = \case+          Required -> fore red "required"+          Optional _ -> fore blue "optional"+        mDefaultValue = \case+          Required -> Nothing+          Optional mdv -> mdv+     in let keySchemaChunks = goValue ks+            defaultValueLine = case mDefaultValue kr of+              Nothing -> []+              Just defaultValue ->+                case jsonValueChunks defaultValue of+                  [c] -> [chunk "# default: " : map (fore magenta) c]+                  cs -> [chunk "# default: "] : map ((chunk "#   " :) . map (fore magenta)) cs+            prefixLines = ["# ", requirementComment kr] : defaultValueLine ++ maybe [] docToLines mdoc+         in addInFrontOfFirstInList [fore white $ chunk k, ": "] (prefixLines ++ keySchemaChunks)+  ObjectAllOfSchema ne -> concatMap goObject $ NE.toList ne+  ObjectAnyOfSchema ne -> anyOfChunks $ NE.map goObject ne+  ObjectOneOfSchema ne -> oneOfChunks $ NE.map goObject ne