{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Autodocodec.Yaml.Schema where
import Autodocodec
import Autodocodec.Schema
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Scientific (Scientific, floatingOrInteger)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TE
import Data.Yaml as Yaml
import Text.Colour
renderColouredSchemaViaCodec :: forall a. HasCodec a => Text
renderColouredSchemaViaCodec :: forall a. HasCodec a => Text
renderColouredSchemaViaCodec = forall input output. ValueCodec input output -> Text
renderColouredSchemaVia (forall value. HasCodec value => JSONCodec value
codec @a)
renderColouredSchemaVia :: ValueCodec input output -> Text
renderColouredSchemaVia :: forall input output. ValueCodec input output -> Text
renderColouredSchemaVia = forall (f :: * -> *).
Foldable f =>
TerminalCapabilities -> f Chunk -> Text
renderChunksText TerminalCapabilities
With24BitColours forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall input output. ValueCodec input output -> [Chunk]
schemaChunksVia
renderPlainSchemaViaCodec :: forall a. HasCodec a => Text
renderPlainSchemaViaCodec :: forall a. HasCodec a => Text
renderPlainSchemaViaCodec = forall input output. ValueCodec input output -> Text
renderPlainSchemaVia (forall value. HasCodec value => JSONCodec value
codec @a)
renderPlainSchemaVia :: ValueCodec input output -> Text
renderPlainSchemaVia :: forall input output. ValueCodec input output -> Text
renderPlainSchemaVia = forall (f :: * -> *).
Foldable f =>
TerminalCapabilities -> f Chunk -> Text
renderChunksText TerminalCapabilities
WithoutColours forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall input output. ValueCodec input output -> [Chunk]
schemaChunksVia
schemaChunksViaCodec :: forall a. HasCodec a => [Chunk]
schemaChunksViaCodec :: forall a. HasCodec a => [Chunk]
schemaChunksViaCodec = forall input output. ValueCodec input output -> [Chunk]
schemaChunksVia (forall value. HasCodec value => JSONCodec value
codec @a)
schemaChunksVia :: ValueCodec input output -> [Chunk]
schemaChunksVia :: forall input output. ValueCodec input output -> [Chunk]
schemaChunksVia = JSONSchema -> [Chunk]
jsonSchemaChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall input output. ValueCodec input output -> JSONSchema
jsonSchemaVia
jsonSchemaChunks :: JSONSchema -> [Chunk]
jsonSchemaChunks :: JSONSchema -> [Chunk]
jsonSchemaChunks = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Chunk]
l -> [Chunk]
l forall a. [a] -> [a] -> [a]
++ [Chunk
"\n"]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> [[Chunk]]
go
where
indent :: [[Chunk]] -> [[Chunk]]
indent :: [[Chunk]] -> [[Chunk]]
indent = forall a b. (a -> b) -> [a] -> [b]
map (Chunk
" " forall a. a -> [a] -> [a]
:)
addInFrontOfFirstInList :: [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList :: [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Chunk]
cs = \case
[] -> [[Chunk]
cs]
([Chunk]
l : [[Chunk]]
ls) -> ([Chunk]
cs forall a. [a] -> [a] -> [a]
++ [Chunk]
l) forall a. a -> [a] -> [a]
: [[Chunk]] -> [[Chunk]]
indent [[Chunk]]
ls
jsonValueChunks :: Yaml.Value -> [[Chunk]]
jsonValueChunks :: Value -> [[Chunk]]
jsonValueChunks Value
v = forall a b. (a -> b) -> [a] -> [b]
map ((forall a. a -> [a] -> [a]
: []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Chunk
chunk) forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode (forall a. ToJSON a => a -> ByteString
Yaml.encode Value
v)
docToLines :: Text -> [[Chunk]]
docToLines :: Text -> [[Chunk]]
docToLines Text
doc = forall a b. (a -> b) -> [a] -> [b]
map (\Text
line -> [Text -> Chunk
chunk Text
"# ", Text -> Chunk
chunk Text
line]) (Text -> [Text]
T.lines Text
doc)
choiceChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
choiceChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
choiceChunks = \case
[[Chunk]]
chunks :| [] -> [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Chunk
"[ "] [[Chunk]]
chunks forall a. [a] -> [a] -> [a]
++ [[Chunk
"]"]]
([[Chunk]]
chunks :| [[[Chunk]]]
restChunks) ->
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Chunk
"[ "] [[Chunk]]
chunks forall a. a -> [a] -> [a]
:
forall a b. (a -> b) -> [a] -> [b]
map ([Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Chunk
", "]) [[[Chunk]]]
restChunks forall a. [a] -> [a] -> [a]
++ [[[Chunk
"]"]]]
anyOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
anyOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
anyOfChunks = ([Chunk
"# ", Colour -> Chunk -> Chunk
fore Colour
green Chunk
"any of"] forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [[Chunk]] -> [[Chunk]]
choiceChunks
oneOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
oneOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
oneOfChunks = ([Chunk
"# ", Colour -> Chunk -> Chunk
fore Colour
green Chunk
"one of"] forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [[Chunk]] -> [[Chunk]]
choiceChunks
orNullChunks :: JSONSchema -> [[Chunk]]
orNullChunks :: JSONSchema -> [[Chunk]]
orNullChunks = ([Chunk
"# ", Colour -> Chunk -> Chunk
fore Colour
green Chunk
"or null"] forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> [[Chunk]]
go
go :: JSONSchema -> [[Chunk]]
go :: JSONSchema -> [[Chunk]]
go = \case
JSONSchema
AnySchema -> [[Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"<any>"]]
JSONSchema
NullSchema -> [[Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"null"]]
JSONSchema
BoolSchema -> [[Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"<boolean>"]]
JSONSchema
StringSchema -> [[Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"<string>"]]
NumberSchema Maybe NumberBounds
mBounds -> case Maybe NumberBounds
mBounds of
Maybe NumberBounds
Nothing -> [[Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"<number>"]]
Just NumberBounds {Scientific
numberBoundsLower :: NumberBounds -> Scientific
numberBoundsUpper :: NumberBounds -> Scientific
numberBoundsUpper :: Scientific
numberBoundsLower :: Scientific
..} ->
let scientificChunk :: Scientific -> Chunk
scientificChunk Scientific
s = Text -> Chunk
chunk forall a b. (a -> b) -> a -> b
$
String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ case forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
s of
Left (Double
_ :: Double) -> forall a. Show a => a -> String
show (Scientific
s :: Scientific)
Right Integer
i -> forall a. Show a => a -> String
show (Integer
i :: Integer)
in [ [ Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
"<number>",
Chunk
" # between ",
Colour -> Chunk -> Chunk
fore Colour
green forall a b. (a -> b) -> a -> b
$ Scientific -> Chunk
scientificChunk Scientific
numberBoundsLower,
Chunk
" and ",
Colour -> Chunk -> Chunk
fore Colour
green forall a b. (a -> b) -> a -> b
$ Scientific -> Chunk
scientificChunk Scientific
numberBoundsUpper
]
]
ArraySchema JSONSchema
s ->
let addListMarker :: [[Chunk]] -> [[Chunk]]
addListMarker = [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Chunk
"- "]
in [[Chunk]] -> [[Chunk]]
addListMarker forall a b. (a -> b) -> a -> b
$ JSONSchema -> [[Chunk]]
go JSONSchema
s
MapSchema JSONSchema
s ->
[Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Colour -> Chunk -> Chunk
fore Colour
white Chunk
"<key>", Chunk
": "] forall a b. (a -> b) -> a -> b
$ [] forall a. a -> [a] -> [a]
: JSONSchema -> [[Chunk]]
go JSONSchema
s
ObjectSchema ObjectSchema
os -> ObjectSchema -> [[Chunk]]
goObject ObjectSchema
os
ValueSchema Value
v -> Value -> [[Chunk]]
jsonValueChunks Value
v
AnyOfSchema NonEmpty JSONSchema
ne -> case NonEmpty JSONSchema
ne of
(JSONSchema
NullSchema :| [JSONSchema
s]) -> JSONSchema -> [[Chunk]]
orNullChunks JSONSchema
s
(JSONSchema
s :| [JSONSchema
NullSchema]) -> JSONSchema -> [[Chunk]]
orNullChunks JSONSchema
s
NonEmpty JSONSchema
_ -> NonEmpty [[Chunk]] -> [[Chunk]]
anyOfChunks forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map JSONSchema -> [[Chunk]]
go NonEmpty JSONSchema
ne
OneOfSchema NonEmpty JSONSchema
ne -> case NonEmpty JSONSchema
ne of
(JSONSchema
NullSchema :| [JSONSchema
s]) -> JSONSchema -> [[Chunk]]
orNullChunks JSONSchema
s
(JSONSchema
s :| [JSONSchema
NullSchema]) -> JSONSchema -> [[Chunk]]
orNullChunks JSONSchema
s
NonEmpty JSONSchema
_ -> NonEmpty [[Chunk]] -> [[Chunk]]
oneOfChunks forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map JSONSchema -> [[Chunk]]
go NonEmpty JSONSchema
ne
CommentSchema Text
comment JSONSchema
s -> Text -> [[Chunk]]
docToLines Text
comment forall a. [a] -> [a] -> [a]
++ JSONSchema -> [[Chunk]]
go JSONSchema
s
RefSchema Text
name -> [[Colour -> Chunk -> Chunk
fore Colour
cyan forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk forall a b. (a -> b) -> a -> b
$ Text
"ref: " forall a. Semigroup a => a -> a -> a
<> Text
name]]
WithDefSchema Map Text JSONSchema
defs (RefSchema Text
_) -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Text
name, JSONSchema
s') -> [Colour -> Chunk -> Chunk
fore Colour
cyan forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk forall a b. (a -> b) -> a -> b
$ Text
"def: " forall a. Semigroup a => a -> a -> a
<> Text
name] forall a. a -> [a] -> [a]
: JSONSchema -> [[Chunk]]
go JSONSchema
s') (forall k a. Map k a -> [(k, a)]
M.toList Map Text JSONSchema
defs)
WithDefSchema Map Text JSONSchema
defs JSONSchema
s -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Text
name, JSONSchema
s') -> [Colour -> Chunk -> Chunk
fore Colour
cyan forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk forall a b. (a -> b) -> a -> b
$ Text
"def: " forall a. Semigroup a => a -> a -> a
<> Text
name] forall a. a -> [a] -> [a]
: JSONSchema -> [[Chunk]]
go JSONSchema
s') (forall k a. Map k a -> [(k, a)]
M.toList Map Text JSONSchema
defs) forall a. [a] -> [a] -> [a]
++ JSONSchema -> [[Chunk]]
go JSONSchema
s
goObject :: ObjectSchema -> [[Chunk]]
goObject :: ObjectSchema -> [[Chunk]]
goObject = \case
ObjectSchema
ObjectAnySchema -> [[Chunk
"<object>"]]
ObjectKeySchema Text
k KeyRequirement
kr JSONSchema
ks Maybe Text
mdoc ->
let requirementComment :: KeyRequirement -> Chunk
requirementComment = \case
KeyRequirement
Required -> Colour -> Chunk -> Chunk
fore Colour
red Chunk
"required"
Optional Maybe Value
_ -> Colour -> Chunk -> Chunk
fore Colour
blue Chunk
"optional"
mDefaultValue :: KeyRequirement -> Maybe Value
mDefaultValue = \case
KeyRequirement
Required -> forall a. Maybe a
Nothing
Optional Maybe Value
mdv -> Maybe Value
mdv
in let keySchemaChunks :: [[Chunk]]
keySchemaChunks = JSONSchema -> [[Chunk]]
go JSONSchema
ks
defaultValueLine :: [[Chunk]]
defaultValueLine = case KeyRequirement -> Maybe Value
mDefaultValue KeyRequirement
kr of
Maybe Value
Nothing -> []
Just Value
defaultValue ->
case Value -> [[Chunk]]
jsonValueChunks Value
defaultValue of
[[Chunk]
c] -> [Text -> Chunk
chunk Text
"# default: " forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Colour -> Chunk -> Chunk
fore Colour
magenta) [Chunk]
c]
[[Chunk]]
cs -> [Text -> Chunk
chunk Text
"# default: "] forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Chunk
chunk Text
"# " forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Colour -> Chunk -> Chunk
fore Colour
magenta)) [[Chunk]]
cs
prefixLines :: [[Chunk]]
prefixLines = [Chunk
"# ", KeyRequirement -> Chunk
requirementComment KeyRequirement
kr] forall a. a -> [a] -> [a]
: [[Chunk]]
defaultValueLine forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> [[Chunk]]
docToLines Maybe Text
mdoc
in [Chunk] -> [[Chunk]] -> [[Chunk]]
addInFrontOfFirstInList [Colour -> Chunk -> Chunk
fore Colour
white forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk Text
k, Chunk
": "] ([[Chunk]]
prefixLines forall a. [a] -> [a] -> [a]
++ [[Chunk]]
keySchemaChunks)
ObjectAllOfSchema NonEmpty ObjectSchema
ne -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ObjectSchema -> [[Chunk]]
goObject forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty ObjectSchema
ne
ObjectAnyOfSchema NonEmpty ObjectSchema
ne -> NonEmpty [[Chunk]] -> [[Chunk]]
anyOfChunks forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ObjectSchema -> [[Chunk]]
goObject NonEmpty ObjectSchema
ne
ObjectOneOfSchema NonEmpty ObjectSchema
ne -> NonEmpty [[Chunk]] -> [[Chunk]]
oneOfChunks forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ObjectSchema -> [[Chunk]]
goObject NonEmpty ObjectSchema
ne