{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

module KDL.Decoder.Schema (
  SchemaOf,
  Schema (..),
  SchemaItem (..),
  TypedNodeSchema (..),
  TypedValueSchema (..),
  schemaJoin,
  schemaAlt,

  -- * Fold over schema items
  foldSchema,
  getValueSchemaNames,
) where

import Data.Text (Text)
import Data.Typeable (TypeRep)
import KDL.Types (
  Node,
  NodeList,
  Value,
 )

type SchemaOf o = Schema (SchemaItem o)

data Schema a
  = SchemaOne a
  | SchemaSome (Schema a)
  | SchemaAnd [Schema a]
  | SchemaOr [Schema a]
  | SchemaUnknown
  deriving (Int -> Schema a -> ShowS
[Schema a] -> ShowS
Schema a -> String
(Int -> Schema a -> ShowS)
-> (Schema a -> String) -> ([Schema a] -> ShowS) -> Show (Schema a)
forall a. Show a => Int -> Schema a -> ShowS
forall a. Show a => [Schema a] -> ShowS
forall a. Show a => Schema a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Schema a -> ShowS
showsPrec :: Int -> Schema a -> ShowS
$cshow :: forall a. Show a => Schema a -> String
show :: Schema a -> String
$cshowList :: forall a. Show a => [Schema a] -> ShowS
showList :: [Schema a] -> ShowS
Show, Schema a -> Schema a -> Bool
(Schema a -> Schema a -> Bool)
-> (Schema a -> Schema a -> Bool) -> Eq (Schema a)
forall a. Eq a => Schema a -> Schema a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Schema a -> Schema a -> Bool
== :: Schema a -> Schema a -> Bool
$c/= :: forall a. Eq a => Schema a -> Schema a -> Bool
/= :: Schema a -> Schema a -> Bool
Eq)

data family SchemaItem a

data instance SchemaItem NodeList
  = NodeNamed Text TypedNodeSchema
  | RemainingNodes TypedNodeSchema
  deriving (Int -> SchemaItem NodeList -> ShowS
[SchemaItem NodeList] -> ShowS
SchemaItem NodeList -> String
(Int -> SchemaItem NodeList -> ShowS)
-> (SchemaItem NodeList -> String)
-> ([SchemaItem NodeList] -> ShowS)
-> Show (SchemaItem NodeList)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SchemaItem NodeList -> ShowS
showsPrec :: Int -> SchemaItem NodeList -> ShowS
$cshow :: SchemaItem NodeList -> String
show :: SchemaItem NodeList -> String
$cshowList :: [SchemaItem NodeList] -> ShowS
showList :: [SchemaItem NodeList] -> ShowS
Show, SchemaItem NodeList -> SchemaItem NodeList -> Bool
(SchemaItem NodeList -> SchemaItem NodeList -> Bool)
-> (SchemaItem NodeList -> SchemaItem NodeList -> Bool)
-> Eq (SchemaItem NodeList)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SchemaItem NodeList -> SchemaItem NodeList -> Bool
== :: SchemaItem NodeList -> SchemaItem NodeList -> Bool
$c/= :: SchemaItem NodeList -> SchemaItem NodeList -> Bool
/= :: SchemaItem NodeList -> SchemaItem NodeList -> Bool
Eq)

data TypedNodeSchema = TypedNodeSchema
  { TypedNodeSchema -> TypeRep
typeHint :: TypeRep
  , TypedNodeSchema -> [Text]
validTypeAnns :: [Text]
  , TypedNodeSchema -> SchemaOf Node
nodeSchema :: SchemaOf Node
  }
  deriving (Int -> TypedNodeSchema -> ShowS
[TypedNodeSchema] -> ShowS
TypedNodeSchema -> String
(Int -> TypedNodeSchema -> ShowS)
-> (TypedNodeSchema -> String)
-> ([TypedNodeSchema] -> ShowS)
-> Show TypedNodeSchema
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypedNodeSchema -> ShowS
showsPrec :: Int -> TypedNodeSchema -> ShowS
$cshow :: TypedNodeSchema -> String
show :: TypedNodeSchema -> String
$cshowList :: [TypedNodeSchema] -> ShowS
showList :: [TypedNodeSchema] -> ShowS
Show, TypedNodeSchema -> TypedNodeSchema -> Bool
(TypedNodeSchema -> TypedNodeSchema -> Bool)
-> (TypedNodeSchema -> TypedNodeSchema -> Bool)
-> Eq TypedNodeSchema
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypedNodeSchema -> TypedNodeSchema -> Bool
== :: TypedNodeSchema -> TypedNodeSchema -> Bool
$c/= :: TypedNodeSchema -> TypedNodeSchema -> Bool
/= :: TypedNodeSchema -> TypedNodeSchema -> Bool
Eq)

data instance SchemaItem Node
  = NodeArg TypedValueSchema
  | NodeProp Text TypedValueSchema
  | NodeRemainingProps TypedValueSchema
  | NodeChildren (SchemaOf NodeList)
  deriving (Int -> SchemaItem Node -> ShowS
[SchemaItem Node] -> ShowS
SchemaItem Node -> String
(Int -> SchemaItem Node -> ShowS)
-> (SchemaItem Node -> String)
-> ([SchemaItem Node] -> ShowS)
-> Show (SchemaItem Node)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SchemaItem Node -> ShowS
showsPrec :: Int -> SchemaItem Node -> ShowS
$cshow :: SchemaItem Node -> String
show :: SchemaItem Node -> String
$cshowList :: [SchemaItem Node] -> ShowS
showList :: [SchemaItem Node] -> ShowS
Show, SchemaItem Node -> SchemaItem Node -> Bool
(SchemaItem Node -> SchemaItem Node -> Bool)
-> (SchemaItem Node -> SchemaItem Node -> Bool)
-> Eq (SchemaItem Node)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SchemaItem Node -> SchemaItem Node -> Bool
== :: SchemaItem Node -> SchemaItem Node -> Bool
$c/= :: SchemaItem Node -> SchemaItem Node -> Bool
/= :: SchemaItem Node -> SchemaItem Node -> Bool
Eq)

data TypedValueSchema = TypedValueSchema
  { TypedValueSchema -> TypeRep
typeHint :: TypeRep
  , TypedValueSchema -> [Text]
validTypeAnns :: [Text]
  , TypedValueSchema -> SchemaOf Value
dataSchema :: SchemaOf Value
  }
  deriving (Int -> TypedValueSchema -> ShowS
[TypedValueSchema] -> ShowS
TypedValueSchema -> String
(Int -> TypedValueSchema -> ShowS)
-> (TypedValueSchema -> String)
-> ([TypedValueSchema] -> ShowS)
-> Show TypedValueSchema
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypedValueSchema -> ShowS
showsPrec :: Int -> TypedValueSchema -> ShowS
$cshow :: TypedValueSchema -> String
show :: TypedValueSchema -> String
$cshowList :: [TypedValueSchema] -> ShowS
showList :: [TypedValueSchema] -> ShowS
Show, TypedValueSchema -> TypedValueSchema -> Bool
(TypedValueSchema -> TypedValueSchema -> Bool)
-> (TypedValueSchema -> TypedValueSchema -> Bool)
-> Eq TypedValueSchema
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypedValueSchema -> TypedValueSchema -> Bool
== :: TypedValueSchema -> TypedValueSchema -> Bool
$c/= :: TypedValueSchema -> TypedValueSchema -> Bool
/= :: TypedValueSchema -> TypedValueSchema -> Bool
Eq)

data instance SchemaItem Value
  = StringSchema
  | NumberSchema
  | BoolSchema
  | NullSchema
  deriving (Int -> SchemaItem Value -> ShowS
[SchemaItem Value] -> ShowS
SchemaItem Value -> String
(Int -> SchemaItem Value -> ShowS)
-> (SchemaItem Value -> String)
-> ([SchemaItem Value] -> ShowS)
-> Show (SchemaItem Value)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SchemaItem Value -> ShowS
showsPrec :: Int -> SchemaItem Value -> ShowS
$cshow :: SchemaItem Value -> String
show :: SchemaItem Value -> String
$cshowList :: [SchemaItem Value] -> ShowS
showList :: [SchemaItem Value] -> ShowS
Show, SchemaItem Value -> SchemaItem Value -> Bool
(SchemaItem Value -> SchemaItem Value -> Bool)
-> (SchemaItem Value -> SchemaItem Value -> Bool)
-> Eq (SchemaItem Value)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SchemaItem Value -> SchemaItem Value -> Bool
== :: SchemaItem Value -> SchemaItem Value -> Bool
$c/= :: SchemaItem Value -> SchemaItem Value -> Bool
/= :: SchemaItem Value -> SchemaItem Value -> Bool
Eq, Eq (SchemaItem Value)
Eq (SchemaItem Value) =>
(SchemaItem Value -> SchemaItem Value -> Ordering)
-> (SchemaItem Value -> SchemaItem Value -> Bool)
-> (SchemaItem Value -> SchemaItem Value -> Bool)
-> (SchemaItem Value -> SchemaItem Value -> Bool)
-> (SchemaItem Value -> SchemaItem Value -> Bool)
-> (SchemaItem Value -> SchemaItem Value -> SchemaItem Value)
-> (SchemaItem Value -> SchemaItem Value -> SchemaItem Value)
-> Ord (SchemaItem Value)
SchemaItem Value -> SchemaItem Value -> Bool
SchemaItem Value -> SchemaItem Value -> Ordering
SchemaItem Value -> SchemaItem Value -> SchemaItem Value
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SchemaItem Value -> SchemaItem Value -> Ordering
compare :: SchemaItem Value -> SchemaItem Value -> Ordering
$c< :: SchemaItem Value -> SchemaItem Value -> Bool
< :: SchemaItem Value -> SchemaItem Value -> Bool
$c<= :: SchemaItem Value -> SchemaItem Value -> Bool
<= :: SchemaItem Value -> SchemaItem Value -> Bool
$c> :: SchemaItem Value -> SchemaItem Value -> Bool
> :: SchemaItem Value -> SchemaItem Value -> Bool
$c>= :: SchemaItem Value -> SchemaItem Value -> Bool
>= :: SchemaItem Value -> SchemaItem Value -> Bool
$cmax :: SchemaItem Value -> SchemaItem Value -> SchemaItem Value
max :: SchemaItem Value -> SchemaItem Value -> SchemaItem Value
$cmin :: SchemaItem Value -> SchemaItem Value -> SchemaItem Value
min :: SchemaItem Value -> SchemaItem Value -> SchemaItem Value
Ord, Int -> SchemaItem Value
SchemaItem Value -> Int
SchemaItem Value -> [SchemaItem Value]
SchemaItem Value -> SchemaItem Value
SchemaItem Value -> SchemaItem Value -> [SchemaItem Value]
SchemaItem Value
-> SchemaItem Value -> SchemaItem Value -> [SchemaItem Value]
(SchemaItem Value -> SchemaItem Value)
-> (SchemaItem Value -> SchemaItem Value)
-> (Int -> SchemaItem Value)
-> (SchemaItem Value -> Int)
-> (SchemaItem Value -> [SchemaItem Value])
-> (SchemaItem Value -> SchemaItem Value -> [SchemaItem Value])
-> (SchemaItem Value -> SchemaItem Value -> [SchemaItem Value])
-> (SchemaItem Value
    -> SchemaItem Value -> SchemaItem Value -> [SchemaItem Value])
-> Enum (SchemaItem Value)
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SchemaItem Value -> SchemaItem Value
succ :: SchemaItem Value -> SchemaItem Value
$cpred :: SchemaItem Value -> SchemaItem Value
pred :: SchemaItem Value -> SchemaItem Value
$ctoEnum :: Int -> SchemaItem Value
toEnum :: Int -> SchemaItem Value
$cfromEnum :: SchemaItem Value -> Int
fromEnum :: SchemaItem Value -> Int
$cenumFrom :: SchemaItem Value -> [SchemaItem Value]
enumFrom :: SchemaItem Value -> [SchemaItem Value]
$cenumFromThen :: SchemaItem Value -> SchemaItem Value -> [SchemaItem Value]
enumFromThen :: SchemaItem Value -> SchemaItem Value -> [SchemaItem Value]
$cenumFromTo :: SchemaItem Value -> SchemaItem Value -> [SchemaItem Value]
enumFromTo :: SchemaItem Value -> SchemaItem Value -> [SchemaItem Value]
$cenumFromThenTo :: SchemaItem Value
-> SchemaItem Value -> SchemaItem Value -> [SchemaItem Value]
enumFromThenTo :: SchemaItem Value
-> SchemaItem Value -> SchemaItem Value -> [SchemaItem Value]
Enum, SchemaItem Value
SchemaItem Value -> SchemaItem Value -> Bounded (SchemaItem Value)
forall a. a -> a -> Bounded a
$cminBound :: SchemaItem Value
minBound :: SchemaItem Value
$cmaxBound :: SchemaItem Value
maxBound :: SchemaItem Value
Bounded)

schemaJoin :: Schema a -> Schema a -> Schema a
schemaJoin :: forall a. Schema a -> Schema a -> Schema a
schemaJoin = ((Schema a, Schema a) -> Schema a)
-> Schema a -> Schema a -> Schema a
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((Schema a, Schema a) -> Schema a)
 -> Schema a -> Schema a -> Schema a)
-> ((Schema a, Schema a) -> Schema a)
-> Schema a
-> Schema a
-> Schema a
forall a b. (a -> b) -> a -> b
$ \case
  (SchemaAnd [Schema a]
l, SchemaAnd [Schema a]
r) -> [Schema a] -> Schema a
forall a. [Schema a] -> Schema a
SchemaAnd ([Schema a]
l [Schema a] -> [Schema a] -> [Schema a]
forall a. Semigroup a => a -> a -> a
<> [Schema a]
r)
  (Schema a
l, SchemaAnd []) -> Schema a
l
  (Schema a
l, SchemaAnd [Schema a]
r) -> [Schema a] -> Schema a
forall a. [Schema a] -> Schema a
SchemaAnd (Schema a
l Schema a -> [Schema a] -> [Schema a]
forall a. a -> [a] -> [a]
: [Schema a]
r)
  (SchemaAnd [], Schema a
r) -> Schema a
r
  (SchemaAnd [Schema a]
l, Schema a
r) -> [Schema a] -> Schema a
forall a. [Schema a] -> Schema a
SchemaAnd ([Schema a]
l [Schema a] -> [Schema a] -> [Schema a]
forall a. Semigroup a => a -> a -> a
<> [Schema a
r])
  (Schema a
l, Schema a
r) -> [Schema a] -> Schema a
forall a. [Schema a] -> Schema a
SchemaAnd [Schema a
l, Schema a
r]

schemaAlt :: Schema a -> Schema a -> Schema a
schemaAlt :: forall a. Schema a -> Schema a -> Schema a
schemaAlt = ((Schema a, Schema a) -> Schema a)
-> Schema a -> Schema a -> Schema a
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((Schema a, Schema a) -> Schema a)
 -> Schema a -> Schema a -> Schema a)
-> ((Schema a, Schema a) -> Schema a)
-> Schema a
-> Schema a
-> Schema a
forall a b. (a -> b) -> a -> b
$ \case
  (SchemaOr [Schema a]
l, SchemaOr [Schema a]
r) -> [Schema a] -> Schema a
forall a. [Schema a] -> Schema a
SchemaOr ([Schema a]
l [Schema a] -> [Schema a] -> [Schema a]
forall a. Semigroup a => a -> a -> a
<> [Schema a]
r)
  (Schema a
l, SchemaOr []) -> Schema a
l
  (Schema a
l, SchemaOr [Schema a]
r) -> [Schema a] -> Schema a
forall a. [Schema a] -> Schema a
SchemaOr (Schema a
l Schema a -> [Schema a] -> [Schema a]
forall a. a -> [a] -> [a]
: [Schema a]
r)
  (SchemaOr [], Schema a
r) -> Schema a
r
  (SchemaOr [Schema a]
l, Schema a
r) -> [Schema a] -> Schema a
forall a. [Schema a] -> Schema a
SchemaOr ([Schema a]
l [Schema a] -> [Schema a] -> [Schema a]
forall a. Semigroup a => a -> a -> a
<> [Schema a
r])
  (Schema a
l, Schema a
r) -> [Schema a] -> Schema a
forall a. [Schema a] -> Schema a
SchemaOr [Schema a
l, Schema a
r]

{------ Fold over schema items -----}

foldSchema :: (SchemaItem a -> b) -> SchemaOf a -> [b]
foldSchema :: forall a b. (SchemaItem a -> b) -> SchemaOf a -> [b]
foldSchema SchemaItem a -> b
f = Schema (SchemaItem a) -> [b]
go
 where
  go :: Schema (SchemaItem a) -> [b]
go = \case
    SchemaOne SchemaItem a
valSchema -> [SchemaItem a -> b
f SchemaItem a
valSchema]
    SchemaSome Schema (SchemaItem a)
s -> Schema (SchemaItem a) -> [b]
go Schema (SchemaItem a)
s
    SchemaAnd [Schema (SchemaItem a)]
ss -> (Schema (SchemaItem a) -> [b]) -> [Schema (SchemaItem a)] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Schema (SchemaItem a) -> [b]
go [Schema (SchemaItem a)]
ss
    SchemaOr [Schema (SchemaItem a)]
ss -> (Schema (SchemaItem a) -> [b]) -> [Schema (SchemaItem a)] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Schema (SchemaItem a) -> [b]
go [Schema (SchemaItem a)]
ss
    Schema (SchemaItem a)
SchemaUnknown -> []

getValueSchemaNames :: SchemaOf Value -> [Text]
getValueSchemaNames :: SchemaOf Value -> [Text]
getValueSchemaNames = (SchemaItem Value -> Text) -> SchemaOf Value -> [Text]
forall a b. (SchemaItem a -> b) -> SchemaOf a -> [b]
foldSchema ((SchemaItem Value -> Text) -> SchemaOf Value -> [Text])
-> (SchemaItem Value -> Text) -> SchemaOf Value -> [Text]
forall a b. (a -> b) -> a -> b
$ \case
  SchemaItem Value
R:SchemaItemValue
StringSchema -> Text
"string"
  SchemaItem Value
R:SchemaItemValue
NumberSchema -> Text
"number"
  SchemaItem Value
R:SchemaItemValue
BoolSchema -> Text
"bool"
  SchemaItem Value
R:SchemaItemValue
NullSchema -> Text
"null"