{-# 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

-- | Render a human-readable schema for a type's 'codec', in 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)

-- | Render a human-readable schema for a given codec, in colour.
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

-- | Render a human-readable schema for a type's 'codec', without colour.
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)

-- | Render a human-readable schema for a given codec, without colour.
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

-- | Produce potentially-coloured 'Chunk's for a human-readable schema for a type's 'codec'.
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)

-- | Produce potentially-coloured 'Chunk's for a human-readable schema for a given codec.
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

-- | Render a 'JSONSchema' as 'Chunk's
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] -- Shouldn't happen, but fine if it doesn't
      ([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