{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module YamlParse.Applicative.Explain where

import Data.Text (Text)
import qualified Data.Text as T
import Data.Validity
import Data.Validity.Text ()
import GHC.Generics (Generic)
import YamlParse.Applicative.Parser

-- A schema for a parser.
--
-- This is used to produce documentation for what/how the parser parses.
data Schema
  = EmptySchema
  | AnySchema
  | ExactSchema Text
  | NullSchema
  | MaybeSchema Schema
  | BoolSchema (Maybe Text)
  | NumberSchema (Maybe Text)
  | StringSchema (Maybe Text)
  | ArraySchema (Maybe Text) Schema
  | ObjectSchema (Maybe Text) Schema
  | FieldSchema
      Text -- Field name
      Bool -- Required
      (Maybe Text) -- Default value
      Schema -- Schema of the value
  | ListSchema Schema
  | MapSchema Schema
  | MapKeysSchema Schema
  | ApSchema Schema Schema -- We'll take this to mean 'and'
  | AltSchema [Schema]
  | CommentSchema Text Schema
  deriving (Int -> Schema -> ShowS
[Schema] -> ShowS
Schema -> String
(Int -> Schema -> ShowS)
-> (Schema -> String) -> ([Schema] -> ShowS) -> Show Schema
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Schema] -> ShowS
$cshowList :: [Schema] -> ShowS
show :: Schema -> String
$cshow :: Schema -> String
showsPrec :: Int -> Schema -> ShowS
$cshowsPrec :: Int -> Schema -> ShowS
Show, Schema -> Schema -> Bool
(Schema -> Schema -> Bool)
-> (Schema -> Schema -> Bool) -> Eq Schema
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Schema -> Schema -> Bool
$c/= :: Schema -> Schema -> Bool
== :: Schema -> Schema -> Bool
$c== :: Schema -> Schema -> Bool
Eq, (forall x. Schema -> Rep Schema x)
-> (forall x. Rep Schema x -> Schema) -> Generic Schema
forall x. Rep Schema x -> Schema
forall x. Schema -> Rep Schema x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Schema x -> Schema
$cfrom :: forall x. Schema -> Rep Schema x
Generic)

instance Validity Schema

-- | Use a parser to produce a schema that describes it for documentation.
--
-- Nothing means that nothing even needs to be parsed, you just get the 'a' without parsing anything.
-- This is for the 'pure' case.
explainParser :: Parser i o -> Schema
explainParser :: Parser i o -> Schema
explainParser = Parser i o -> Schema
forall i o. Parser i o -> Schema
go
  where
    go :: Parser i o -> Schema
    go :: Parser i o -> Schema
go = \case
      Parser i o
ParseAny -> Schema
AnySchema
      ParseExtra o -> Parser o
_ Parser i o
p -> Parser i o -> Schema
forall i o. Parser i o -> Schema
go Parser i o
p
      ParseEq o
_ Text
t Parser i o
_ -> Text -> Schema
ExactSchema Text
t
      Parser i o
ParseNull -> Schema
NullSchema
      ParseMaybe Parser Value o
p -> Schema -> Schema
MaybeSchema (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ Parser Value o -> Schema
forall i o. Parser i o -> Schema
go Parser Value o
p
      ParseBool Maybe Text
t Parser Bool o
_ -> Maybe Text -> Schema
BoolSchema Maybe Text
t
      ParseNumber Maybe Text
t Parser Scientific o
_ -> Maybe Text -> Schema
NumberSchema Maybe Text
t
      ParseString Maybe Text
t Parser Text o
ParseAny -> Maybe Text -> Schema
StringSchema Maybe Text
t
      ParseString Maybe Text
_ Parser Text o
p -> Parser Text o -> Schema
forall i o. Parser i o -> Schema
go Parser Text o
p
      ParseArray Maybe Text
t Parser Array o
p -> Maybe Text -> Schema -> Schema
ArraySchema Maybe Text
t (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ Parser Array o -> Schema
forall i o. Parser i o -> Schema
go Parser Array o
p
      ParseObject Maybe Text
t Parser Object o
p -> Maybe Text -> Schema -> Schema
ObjectSchema Maybe Text
t (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ Parser Object o -> Schema
forall i o. Parser i o -> Schema
go Parser Object o
p
      ParseField Text
k FieldParser o
fp -> case FieldParser o
fp of
        FieldParserFmap a -> o
_ FieldParser a
fp' -> Parser Object a -> Schema
forall i o. Parser i o -> Schema
go (Parser Object a -> Schema) -> Parser Object a -> Schema
forall a b. (a -> b) -> a -> b
$ Text -> FieldParser a -> Parser Object a
forall o. Text -> FieldParser o -> Parser Object o
ParseField Text
k FieldParser a
fp'
        FieldParserRequired YamlParser o
p -> Text -> Bool -> Maybe Text -> Schema -> Schema
FieldSchema Text
k Bool
True Maybe Text
forall a. Maybe a
Nothing (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ YamlParser o -> Schema
forall i o. Parser i o -> Schema
go YamlParser o
p
        FieldParserOptional YamlParser o
p -> Text -> Bool -> Maybe Text -> Schema -> Schema
FieldSchema Text
k Bool
False Maybe Text
forall a. Maybe a
Nothing (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ YamlParser o -> Schema
forall i o. Parser i o -> Schema
go YamlParser o
p
        FieldParserOptionalWithDefault YamlParser o
p o
d -> Text -> Bool -> Maybe Text -> Schema -> Schema
FieldSchema Text
k Bool
False (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ o -> String
forall a. Show a => a -> String
show o
d) (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ YamlParser o -> Schema
forall i o. Parser i o -> Schema
go YamlParser o
p
      ParseList Parser Value o
p -> Schema -> Schema
ListSchema (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ Parser Value o -> Schema
forall i o. Parser i o -> Schema
go Parser Value o
p
      ParseMap Parser Value v
p -> Schema -> Schema
MapSchema (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ Parser Value v -> Schema
forall i o. Parser i o -> Schema
go Parser Value v
p
      ParseMapKeys Parser Text k
_ Parser Object (KeyMap v)
p -> Schema -> Schema
MapKeysSchema (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ Parser Object (KeyMap v) -> Schema
forall i o. Parser i o -> Schema
go Parser Object (KeyMap v)
p
      ParsePure o
_ -> Schema
EmptySchema
      ParseFmap a -> o
_ Parser i a
p -> Parser i a -> Schema
forall i o. Parser i o -> Schema
go Parser i a
p
      ParseAp Parser i (a -> o)
pf Parser i a
p -> Schema -> Schema -> Schema
ApSchema (Parser i (a -> o) -> Schema
forall i o. Parser i o -> Schema
go Parser i (a -> o)
pf) (Parser i a -> Schema
forall i o. Parser i o -> Schema
go Parser i a
p)
      ParseAlt [Parser i o]
ps -> [Schema] -> Schema
AltSchema ([Schema] -> Schema) -> [Schema] -> Schema
forall a b. (a -> b) -> a -> b
$ (Parser i o -> Schema) -> [Parser i o] -> [Schema]
forall a b. (a -> b) -> [a] -> [b]
map Parser i o -> Schema
forall i o. Parser i o -> Schema
go [Parser i o]
ps
      ParseComment Text
t Parser i o
p -> Text -> Schema -> Schema
CommentSchema Text
t (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ Parser i o -> Schema
forall i o. Parser i o -> Schema
go Parser i o
p