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

-- | Render pretty documentation about the 'yamlSchema' of a type
--
-- This is meant for humans.
-- The output may look like YAML but it is not.
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)

-- | Render pretty documentation about a parser
--
-- This is meant for humans.
-- The output may look like YAML but it is not.
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

-- | Render pretty colourised documentation about the 'yamlSchema' of a type
--
-- This is meant for humans.
-- The output may look like YAML but it is not.
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)

-- | Render pretty colourised documentation about a parser
--
-- This is meant for humans.
-- The output may look like YAML but it is not.
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

-- | Render a schema as pretty text.
--
-- This is meant for humans.
-- The output may look like YAML but it is not.
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

-- | Render a schema as pretty and colourised text.
--
-- This is meant for humans.
-- The output may look like YAML but it is not.
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"

-- | A list of comments
newtype Comments = Comments {Comments -> [Doc Colour]
commentsList :: [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
(<>)

-- | No comments
emptyComments :: Comments
emptyComments :: Comments
emptyComments = [Doc Colour] -> Comments
Comments []

-- | A raw text as comments
comment :: Text -> Comments
comment :: Text -> Comments
comment 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

-- | Prettyprint a 'Schema'
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)
            -- The comments really only work on the object level
            -- so they are erased when going down
            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