{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module YamlParse.Applicative.Pretty where
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Text
import Data.Text.Prettyprint.Doc.Render.Util.StackMachine
import YamlParse.Applicative.Class
import YamlParse.Applicative.Explain
import YamlParse.Applicative.Parser
data Colour = Yellow | Gray | Red | Blue | White
prettySchemaDoc :: forall a. YamlSchema a => Text
prettySchemaDoc :: Text
prettySchemaDoc = Parser Value a -> Text
forall i o. Parser i o -> Text
prettyParserDoc (YamlSchema a => Parser Value a
forall a. YamlSchema a => YamlParser a
yamlSchema @a)
prettyParserDoc :: Parser i o -> Text
prettyParserDoc :: Parser i o -> Text
prettyParserDoc = Schema -> Text
prettySchema (Schema -> Text) -> (Parser i o -> Schema) -> Parser i o -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser i o -> Schema
forall i o. Parser i o -> Schema
explainParser
prettyColourisedSchemaDoc :: forall a. YamlSchema a => Text
prettyColourisedSchemaDoc :: Text
prettyColourisedSchemaDoc = Parser Value a -> Text
forall i o. Parser i o -> Text
prettyColourisedParserDoc (YamlSchema a => Parser Value a
forall a. YamlSchema a => YamlParser a
yamlSchema @a)
prettyColourisedParserDoc :: Parser i o -> Text
prettyColourisedParserDoc :: Parser i o -> Text
prettyColourisedParserDoc = Schema -> Text
prettyColourisedSchema (Schema -> Text) -> (Parser i o -> Schema) -> Parser i o -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser i o -> Schema
forall i o. Parser i o -> Schema
explainParser
prettySchema :: Schema -> Text
prettySchema :: Schema -> Text
prettySchema = SimpleDocStream Colour -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream Colour -> Text)
-> (Schema -> SimpleDocStream Colour) -> Schema -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Colour -> SimpleDocStream Colour
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Colour -> SimpleDocStream Colour)
-> (Schema -> Doc Colour) -> Schema -> SimpleDocStream Colour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Doc Colour
schemaDoc
prettyColourisedSchema :: Schema -> Text
prettyColourisedSchema :: Schema -> Text
prettyColourisedSchema = (Text -> Text)
-> (Colour -> Text)
-> (Colour -> Text)
-> SimpleDocStream Colour
-> Text
forall out ann.
Monoid out =>
(Text -> out)
-> (ann -> out) -> (ann -> out) -> SimpleDocStream ann -> out
renderSimplyDecorated Text -> Text
forall a. a -> a
id Colour -> Text
startColour Colour -> Text
resetColour (SimpleDocStream Colour -> Text)
-> (Schema -> SimpleDocStream Colour) -> Schema -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Colour -> SimpleDocStream Colour
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Colour -> SimpleDocStream Colour)
-> (Schema -> Doc Colour) -> Schema -> SimpleDocStream Colour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Doc Colour
schemaDoc
where
startColour :: Colour -> Text
startColour :: Colour -> Text
startColour = \case
Colour
Yellow -> Text
"\x1b[33m"
Colour
Gray -> Text
"\x1b[2m"
Colour
Red -> Text
"\x1b[31m"
Colour
Blue -> Text
"\x1b[34m"
Colour
White -> Text
"\x1b[37m"
resetColour :: Colour -> Text
resetColour :: Colour -> Text
resetColour Colour
_ = Text
"\x1b[0m"
newtype = { :: [Doc Colour]}
deriving (Int -> Comments -> ShowS
[Comments] -> ShowS
Comments -> String
(Int -> Comments -> ShowS)
-> (Comments -> String) -> ([Comments] -> ShowS) -> Show Comments
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Comments] -> ShowS
$cshowList :: [Comments] -> ShowS
show :: Comments -> String
$cshow :: Comments -> String
showsPrec :: Int -> Comments -> ShowS
$cshowsPrec :: Int -> Comments -> ShowS
Show)
instance Semigroup Comments where
(Comments [Doc Colour]
l1) <> :: Comments -> Comments -> Comments
<> (Comments [Doc Colour]
l2) = [Doc Colour] -> Comments
Comments ([Doc Colour] -> Comments) -> [Doc Colour] -> Comments
forall a b. (a -> b) -> a -> b
$ [Doc Colour]
l1 [Doc Colour] -> [Doc Colour] -> [Doc Colour]
forall a. Semigroup a => a -> a -> a
<> [Doc Colour]
l2
instance Monoid Comments where
mempty :: Comments
mempty = Comments
emptyComments
mappend :: Comments -> Comments -> Comments
mappend = Comments -> Comments -> Comments
forall a. Semigroup a => a -> a -> a
(<>)
emptyComments :: Comments
= [Doc Colour] -> Comments
Comments []
comment :: Text -> Comments
Text
t = [Doc Colour] -> Comments
Comments ([Doc Colour] -> Comments) -> [Doc Colour] -> Comments
forall a b. (a -> b) -> a -> b
$ (Text -> Doc Colour) -> [Text] -> [Doc Colour]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc Colour
forall a ann. Pretty a => a -> Doc ann
pretty ([Text] -> [Doc Colour]) -> [Text] -> [Doc Colour]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
t
schemaDoc :: Schema -> Doc Colour
schemaDoc :: Schema -> Doc Colour
schemaDoc = Comments -> Schema -> Doc Colour
go Comments
emptyComments
where
go :: Comments -> Schema -> Doc Colour
go :: Comments -> Schema -> Doc Colour
go Comments
cs =
let g :: Schema -> Doc Colour
g = Comments -> Schema -> Doc Colour
go Comments
cs
ge :: Schema -> Doc Colour
ge = Comments -> Schema -> Doc Colour
go Comments
emptyComments
mkComment :: Doc Colour -> Doc Colour
mkComment :: Doc Colour -> Doc Colour
mkComment = (Doc Colour
"# " Doc Colour -> Doc Colour -> Doc Colour
forall a. Semigroup a => a -> a -> a
<>)
mkCommentsMDoc :: Comments -> Maybe (Doc Colour)
mkCommentsMDoc :: Comments -> Maybe (Doc Colour)
mkCommentsMDoc = \case
Comments [] -> Maybe (Doc Colour)
forall a. Maybe a
Nothing
Comments [Doc Colour]
l -> Doc Colour -> Maybe (Doc Colour)
forall a. a -> Maybe a
Just (Doc Colour -> Maybe (Doc Colour))
-> Doc Colour -> Maybe (Doc Colour)
forall a b. (a -> b) -> a -> b
$ Doc Colour -> Doc Colour
forall ann. Doc ann -> Doc ann
align (Doc Colour -> Doc Colour) -> Doc Colour -> Doc Colour
forall a b. (a -> b) -> a -> b
$ [Doc Colour] -> Doc Colour
forall ann. [Doc ann] -> Doc ann
vsep ([Doc Colour] -> Doc Colour) -> [Doc Colour] -> Doc Colour
forall a b. (a -> b) -> a -> b
$ (Doc Colour -> Doc Colour) -> [Doc Colour] -> [Doc Colour]
forall a b. (a -> b) -> [a] -> [b]
map (Colour -> Doc Colour -> Doc Colour
forall ann. ann -> Doc ann -> Doc ann
annotate Colour
Gray (Doc Colour -> Doc Colour)
-> (Doc Colour -> Doc Colour) -> Doc Colour -> Doc Colour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Colour -> Doc Colour
mkComment) [Doc Colour]
l
addMComment :: Comments -> Maybe Text -> Comments
addMComment :: Comments -> Maybe Text -> Comments
addMComment Comments
c = \case
Maybe Text
Nothing -> Comments
c
Just Text
t -> Comments
c Comments -> Comments -> Comments
forall a. Semigroup a => a -> a -> a
<> Text -> Comments
comment Text
t
e :: Doc Colour -> Comments -> Doc Colour
e :: Doc Colour -> Comments -> Doc Colour
e Doc Colour
s Comments
cs' =
case Comments -> Maybe (Doc Colour)
mkCommentsMDoc Comments
cs' of
Maybe (Doc Colour)
Nothing -> Colour -> Doc Colour -> Doc Colour
forall ann. ann -> Doc ann -> Doc ann
annotate Colour
Yellow Doc Colour
s
Just Doc Colour
cd -> [Doc Colour] -> Doc Colour
forall ann. [Doc ann] -> Doc ann
vsep [Doc Colour
cd, Colour -> Doc Colour -> Doc Colour
forall ann. ann -> Doc ann -> Doc ann
annotate Colour
Yellow Doc Colour
s]
in \case
Schema
EmptySchema -> Doc Colour -> Comments -> Doc Colour
e Doc Colour
forall ann. Doc ann
emptyDoc (Comments -> Doc Colour) -> Comments -> Doc Colour
forall a b. (a -> b) -> a -> b
$ Comments -> Maybe Text -> Comments
addMComment Comments
cs (Maybe Text -> Comments) -> Maybe Text -> Comments
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Nothing to parse"
Schema
AnySchema -> Doc Colour -> Comments -> Doc Colour
e Doc Colour
"<any>" Comments
cs
ExactSchema Text
t -> Doc Colour -> Comments -> Doc Colour
e (Text -> Doc Colour
forall a ann. Pretty a => a -> Doc ann
pretty Text
t) Comments
cs Doc Colour -> Doc Colour -> Doc Colour
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe (Doc Colour) -> Doc Colour
forall a. HasCallStack => Maybe a -> a
fromJust (Comments -> Maybe (Doc Colour)
mkCommentsMDoc (Comments -> Maybe (Doc Colour)) -> Comments -> Maybe (Doc Colour)
forall a b. (a -> b) -> a -> b
$ Text -> Comments
comment Text
"(exact)")
Schema
NullSchema -> Doc Colour -> Comments -> Doc Colour
e Doc Colour
"null" Comments
cs
MaybeSchema Schema
s -> Comments -> Schema -> Doc Colour
go (Text -> Comments
comment Text
"or <null>" Comments -> Comments -> Comments
forall a. Semigroup a => a -> a -> a
<> Comments
cs) Schema
s
BoolSchema Maybe Text
t -> Doc Colour -> Comments -> Doc Colour
e Doc Colour
"<boolean>" (Comments -> Doc Colour) -> Comments -> Doc Colour
forall a b. (a -> b) -> a -> b
$ Comments -> Maybe Text -> Comments
addMComment Comments
cs Maybe Text
t
NumberSchema Maybe Text
t -> Doc Colour -> Comments -> Doc Colour
e Doc Colour
"<number>" (Comments -> Doc Colour) -> Comments -> Doc Colour
forall a b. (a -> b) -> a -> b
$ Comments -> Maybe Text -> Comments
addMComment Comments
cs Maybe Text
t
StringSchema Maybe Text
t -> Doc Colour -> Comments -> Doc Colour
e Doc Colour
"<string>" (Comments -> Doc Colour) -> Comments -> Doc Colour
forall a b. (a -> b) -> a -> b
$ Comments -> Maybe Text -> Comments
addMComment Comments
cs Maybe Text
t
ArraySchema Maybe Text
t Schema
s -> Doc Colour
"-" Doc Colour -> Doc Colour -> Doc Colour
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Colour -> Doc Colour
forall ann. Doc ann -> Doc ann
align (Comments -> Schema -> Doc Colour
go (Comments -> Maybe Text -> Comments
addMComment Comments
cs Maybe Text
t) Schema
s)
ObjectSchema Maybe Text
t Schema
AnySchema -> Doc Colour -> Comments -> Doc Colour
e Doc Colour
"<object>" (Comments -> Maybe Text -> Comments
addMComment Comments
cs Maybe Text
t)
ObjectSchema Maybe Text
t Schema
s -> Doc Colour -> Comments -> Doc Colour
e (Schema -> Doc Colour
ge Schema
s) (Comments -> Maybe Text -> Comments
addMComment Comments
cs Maybe Text
t)
FieldSchema Text
k Bool
r Maybe Text
md Schema
s ->
let keyDoc :: Doc Colour
keyDoc :: Doc Colour
keyDoc = Text -> Doc Colour
forall a ann. Pretty a => a -> Doc ann
pretty Text
k
requiredDoc :: Doc Colour
requiredDoc :: Doc Colour
requiredDoc =
if Bool
r
then Colour -> Doc Colour -> Doc Colour
forall ann. ann -> Doc ann -> Doc ann
annotate Colour
Red Doc Colour
"required"
else case Maybe Text
md of
Maybe Text
Nothing -> Doc Colour
blueOptional
Just Text
d -> Doc Colour
blueOptional Doc Colour -> Doc Colour -> Doc Colour
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Colour
", default:" Doc Colour -> Doc Colour -> Doc Colour
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc Colour
forall a ann. Pretty a => a -> Doc ann
pretty Text
d
where
blueOptional :: Doc Colour
blueOptional = Colour -> Doc Colour -> Doc Colour
forall ann. ann -> Doc ann -> Doc ann
annotate Colour
Blue Doc Colour
"optional"
in [Doc Colour] -> Doc Colour
forall ann. [Doc ann] -> Doc ann
vsep
[ Colour -> Doc Colour -> Doc Colour
forall ann. ann -> Doc ann -> Doc ann
annotate Colour
White Doc Colour
keyDoc Doc Colour -> Doc Colour -> Doc Colour
forall a. Semigroup a => a -> a -> a
<> Doc Colour
":" Doc Colour -> Doc Colour -> Doc Colour
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Colour -> Doc Colour
mkComment Doc Colour
requiredDoc,
Int -> Doc Colour -> Doc Colour
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc Colour -> Doc Colour) -> Doc Colour -> Doc Colour
forall a b. (a -> b) -> a -> b
$ Schema -> Doc Colour
g Schema
s
]
ListSchema Schema
s -> Schema -> Doc Colour
g Schema
s
MapSchema Schema
s -> Doc Colour -> Comments -> Doc Colour
e (Colour -> Doc Colour -> Doc Colour
forall ann. ann -> Doc ann -> Doc ann
annotate Colour
White Doc Colour
"<key>: " Doc Colour -> Doc Colour -> Doc Colour
forall a. Semigroup a => a -> a -> a
<> Int -> Doc Colour -> Doc Colour
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Schema -> Doc Colour
g Schema
s)) Comments
cs
MapKeysSchema Schema
s -> Schema -> Doc Colour
g Schema
s
ApSchema Schema
s1 Schema
s2 -> Doc Colour -> Doc Colour
forall ann. Doc ann -> Doc ann
align (Doc Colour -> Doc Colour) -> Doc Colour -> Doc Colour
forall a b. (a -> b) -> a -> b
$ [Doc Colour] -> Doc Colour
forall ann. [Doc ann] -> Doc ann
vsep [Schema -> Doc Colour
g Schema
s1, Schema -> Doc Colour
g Schema
s2]
AltSchema [Schema]
ss ->
let listDoc :: [Doc Colour] -> Doc Colour
listDoc :: [Doc Colour] -> Doc Colour
listDoc = \case
[] -> Doc Colour
"[]"
(Doc Colour
d : [Doc Colour]
ds) ->
[Doc Colour] -> Doc Colour
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc Colour
"[" Doc Colour -> Doc Colour -> Doc Colour
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc Colour -> Doc Colour
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 Doc Colour
d,
[Doc Colour] -> Doc Colour
forall ann. [Doc ann] -> Doc ann
vsep ([Doc Colour] -> Doc Colour) -> [Doc Colour] -> Doc Colour
forall a b. (a -> b) -> a -> b
$ (Doc Colour -> Doc Colour) -> [Doc Colour] -> [Doc Colour]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc Colour
"," Doc Colour -> Doc Colour -> Doc Colour
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc Colour -> Doc Colour)
-> (Doc Colour -> Doc Colour) -> Doc Colour -> Doc Colour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc Colour -> Doc Colour
forall ann. Int -> Doc ann -> Doc ann
nest Int
2) [Doc Colour]
ds,
Doc Colour
"]"
]
in [Doc Colour] -> Doc Colour
listDoc ([Doc Colour] -> Doc Colour) -> [Doc Colour] -> Doc Colour
forall a b. (a -> b) -> a -> b
$ (Schema -> Doc Colour) -> [Schema] -> [Doc Colour]
forall a b. (a -> b) -> [a] -> [b]
map Schema -> Doc Colour
ge [Schema]
ss
CommentSchema Text
t Schema
s -> Comments -> Schema -> Doc Colour
go (Comments
cs Comments -> Comments -> Comments
forall a. Semigroup a => a -> a -> a
<> Text -> Comments
comment Text
t) Schema
s