{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | LTML types.
--
--   An LTML type is value of an LTML kind, which is a Haskell type
--   (e.g., 'Language.Lsd.AST.Type.Section.SectionType').
--
--   LTML types can be named, by wrapping them as (@'NamedType' t@), where @t@
--   is the specific type/kind.
--
--   A kind @t@ can be represented as Haskell value of type @'Proxy' t@.
module Language.Lsd.AST.Type
    ( NamedType (..)
    , ProperTypeMeta (..)
    , TreeSyntax (..)
    , HasEditableHeader (..)
    , ChildrenOrder (..)
    , ProperNodeKind (..)
    , RawProperNodeKind (..)
    , fullTypeNameOf
    , properTypeMetaOf
    , properTypeCollect
    , properTypeCollect'
    )
where

import Control.Monad.CollectionState
    ( CollectionState
    , collect
    , execCollectionState
    )
import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON))
import Data.Map (Map)
import Data.OpenApi (ToSchema (declareNamedSchema))
import Data.Proxy (Proxy (Proxy))
import GHC.Generics (Generic)
import Language.Lsd.AST.Common
    ( DisplayTypeName
    , FullTypeName
    , KindName
    , TypeName
    )
import Language.Lsd.AST.SimpleRegex (Disjunction (Disjunction))

data NamedType t
    = NamedType
    { forall t. NamedType t -> TypeName
ntTypeName :: TypeName
    , forall t. NamedType t -> DisplayTypeName
ntDisplayName :: DisplayTypeName
    , forall t. NamedType t -> t
unwrapNT :: t
    }

-- | Metadata on a proper (see 'ProperNodeKind') LTML type.
--   To be communicated to and used by the frontend only.  Not used for
--   parsing; some information is duplicated in the parser.
data ProperTypeMeta
    = ProperTypeMeta
        DisplayTypeName
        (TreeSyntax FullTypeName)
    deriving (Int -> ProperTypeMeta -> ShowS
[ProperTypeMeta] -> ShowS
ProperTypeMeta -> String
(Int -> ProperTypeMeta -> ShowS)
-> (ProperTypeMeta -> String)
-> ([ProperTypeMeta] -> ShowS)
-> Show ProperTypeMeta
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProperTypeMeta -> ShowS
showsPrec :: Int -> ProperTypeMeta -> ShowS
$cshow :: ProperTypeMeta -> String
show :: ProperTypeMeta -> String
$cshowList :: [ProperTypeMeta] -> ShowS
showList :: [ProperTypeMeta] -> ShowS
Show, (forall x. ProperTypeMeta -> Rep ProperTypeMeta x)
-> (forall x. Rep ProperTypeMeta x -> ProperTypeMeta)
-> Generic ProperTypeMeta
forall x. Rep ProperTypeMeta x -> ProperTypeMeta
forall x. ProperTypeMeta -> Rep ProperTypeMeta x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ProperTypeMeta -> Rep ProperTypeMeta x
from :: forall x. ProperTypeMeta -> Rep ProperTypeMeta x
$cto :: forall x. Rep ProperTypeMeta x -> ProperTypeMeta
to :: forall x. Rep ProperTypeMeta x -> ProperTypeMeta
Generic)

instance ToJSON ProperTypeMeta

instance FromJSON ProperTypeMeta

instance ToSchema ProperTypeMeta

-- | Syntax of an input tree ('Language.Ltml.Tree.FlaggedInputTree').
--   This information is duplicated in the input tree parser (and, arguably,
--   in the LTML and LSD ASTs, the latter of which it is derived from).
data TreeSyntax a
    = LeafSyntax
    | TreeSyntax
        HasEditableHeader
        (ChildrenOrder a)
    deriving (Int -> TreeSyntax a -> ShowS
[TreeSyntax a] -> ShowS
TreeSyntax a -> String
(Int -> TreeSyntax a -> ShowS)
-> (TreeSyntax a -> String)
-> ([TreeSyntax a] -> ShowS)
-> Show (TreeSyntax a)
forall a. Show a => Int -> TreeSyntax a -> ShowS
forall a. Show a => [TreeSyntax a] -> ShowS
forall a. Show a => TreeSyntax a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TreeSyntax a -> ShowS
showsPrec :: Int -> TreeSyntax a -> ShowS
$cshow :: forall a. Show a => TreeSyntax a -> String
show :: TreeSyntax a -> String
$cshowList :: forall a. Show a => [TreeSyntax a] -> ShowS
showList :: [TreeSyntax a] -> ShowS
Show, (forall x. TreeSyntax a -> Rep (TreeSyntax a) x)
-> (forall x. Rep (TreeSyntax a) x -> TreeSyntax a)
-> Generic (TreeSyntax a)
forall x. Rep (TreeSyntax a) x -> TreeSyntax a
forall x. TreeSyntax a -> Rep (TreeSyntax a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (TreeSyntax a) x -> TreeSyntax a
forall a x. TreeSyntax a -> Rep (TreeSyntax a) x
$cfrom :: forall a x. TreeSyntax a -> Rep (TreeSyntax a) x
from :: forall x. TreeSyntax a -> Rep (TreeSyntax a) x
$cto :: forall a x. Rep (TreeSyntax a) x -> TreeSyntax a
to :: forall x. Rep (TreeSyntax a) x -> TreeSyntax a
Generic)

instance (ToJSON a) => ToJSON (TreeSyntax a)

instance (FromJSON a) => FromJSON (TreeSyntax a)

instance (ToSchema a) => ToSchema (TreeSyntax a)

newtype HasEditableHeader = HasEditableHeader Bool
    deriving (Int -> HasEditableHeader -> ShowS
[HasEditableHeader] -> ShowS
HasEditableHeader -> String
(Int -> HasEditableHeader -> ShowS)
-> (HasEditableHeader -> String)
-> ([HasEditableHeader] -> ShowS)
-> Show HasEditableHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HasEditableHeader -> ShowS
showsPrec :: Int -> HasEditableHeader -> ShowS
$cshow :: HasEditableHeader -> String
show :: HasEditableHeader -> String
$cshowList :: [HasEditableHeader] -> ShowS
showList :: [HasEditableHeader] -> ShowS
Show)

instance ToJSON HasEditableHeader where
    toJSON :: HasEditableHeader -> Value
toJSON (HasEditableHeader Bool
hasEditableHeader) = Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
hasEditableHeader

instance FromJSON HasEditableHeader where
    parseJSON :: Value -> Parser HasEditableHeader
parseJSON = (Bool -> HasEditableHeader)
-> Parser Bool -> Parser HasEditableHeader
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> HasEditableHeader
HasEditableHeader (Parser Bool -> Parser HasEditableHeader)
-> (Value -> Parser Bool) -> Value -> Parser HasEditableHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Bool
forall a. FromJSON a => Value -> Parser a
parseJSON

instance ToSchema HasEditableHeader where
    declareNamedSchema :: Proxy HasEditableHeader -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy HasEditableHeader
_ = Proxy Bool -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy Bool
forall {k} (t :: k). Proxy t
Proxy :: Proxy Bool)

-- | Information on permitted proper (see 'ProperNodeKind') children of proper
--   nodes and their order.
data ChildrenOrder a
    = SequenceOrder [Disjunction a]
    | StarOrder (Disjunction a)
    deriving (Int -> ChildrenOrder a -> ShowS
[ChildrenOrder a] -> ShowS
ChildrenOrder a -> String
(Int -> ChildrenOrder a -> ShowS)
-> (ChildrenOrder a -> String)
-> ([ChildrenOrder a] -> ShowS)
-> Show (ChildrenOrder a)
forall a. Show a => Int -> ChildrenOrder a -> ShowS
forall a. Show a => [ChildrenOrder a] -> ShowS
forall a. Show a => ChildrenOrder a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ChildrenOrder a -> ShowS
showsPrec :: Int -> ChildrenOrder a -> ShowS
$cshow :: forall a. Show a => ChildrenOrder a -> String
show :: ChildrenOrder a -> String
$cshowList :: forall a. Show a => [ChildrenOrder a] -> ShowS
showList :: [ChildrenOrder a] -> ShowS
Show, (forall x. ChildrenOrder a -> Rep (ChildrenOrder a) x)
-> (forall x. Rep (ChildrenOrder a) x -> ChildrenOrder a)
-> Generic (ChildrenOrder a)
forall x. Rep (ChildrenOrder a) x -> ChildrenOrder a
forall x. ChildrenOrder a -> Rep (ChildrenOrder a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ChildrenOrder a) x -> ChildrenOrder a
forall a x. ChildrenOrder a -> Rep (ChildrenOrder a) x
$cfrom :: forall a x. ChildrenOrder a -> Rep (ChildrenOrder a) x
from :: forall x. ChildrenOrder a -> Rep (ChildrenOrder a) x
$cto :: forall a x. Rep (ChildrenOrder a) x -> ChildrenOrder a
to :: forall x. Rep (ChildrenOrder a) x -> ChildrenOrder a
Generic)

instance (ToJSON a) => ToJSON (ChildrenOrder a)

instance (FromJSON a) => FromJSON (ChildrenOrder a)

instance (ToSchema a) => ToSchema (ChildrenOrder a)

-- | A node in the LTML tree is proper iff it corresponds to a node in the
--   input tree ('Language.Ltml.Tree.InputTree').
class ProperNodeKind t where
    kindNameOf :: Proxy t -> KindName
    typeNameOf :: t -> TypeName
    displayTypeNameOf :: t -> DisplayTypeName
    treeSyntaxMap
        :: (forall t'. (ProperNodeKind t') => t' -> a)
        -> t
        -> TreeSyntax a

-- | An LTML kind @t@ is raw-proper iff @'NamedType' t@ is proper
--   (see 'ProperNodeKind').
class RawProperNodeKind t where
    kindNameOfRaw :: Proxy t -> KindName
    treeSyntaxMapRaw
        :: (forall t'. (ProperNodeKind t') => t' -> a)
        -> t
        -> TreeSyntax a

instance (RawProperNodeKind t) => ProperNodeKind (NamedType t) where
    kindNameOf :: Proxy (NamedType t) -> KindName
kindNameOf Proxy (NamedType t)
_ = Proxy t -> KindName
forall t. RawProperNodeKind t => Proxy t -> KindName
kindNameOfRaw (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t)
    typeNameOf :: NamedType t -> TypeName
typeNameOf = NamedType t -> TypeName
forall t. NamedType t -> TypeName
ntTypeName
    displayTypeNameOf :: NamedType t -> DisplayTypeName
displayTypeNameOf = NamedType t -> DisplayTypeName
forall t. NamedType t -> DisplayTypeName
ntDisplayName
    treeSyntaxMap :: forall a.
(forall t'. ProperNodeKind t' => t' -> a)
-> NamedType t -> TreeSyntax a
treeSyntaxMap forall t'. ProperNodeKind t' => t' -> a
f = (forall t'. ProperNodeKind t' => t' -> a) -> t -> TreeSyntax a
forall t a.
RawProperNodeKind t =>
(forall t'. ProperNodeKind t' => t' -> a) -> t -> TreeSyntax a
forall a.
(forall t'. ProperNodeKind t' => t' -> a) -> t -> TreeSyntax a
treeSyntaxMapRaw t' -> a
forall t'. ProperNodeKind t' => t' -> a
f (t -> TreeSyntax a)
-> (NamedType t -> t) -> NamedType t -> TreeSyntax a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedType t -> t
forall t. NamedType t -> t
unwrapNT

fullTypeNameOf :: forall t. (ProperNodeKind t) => t -> FullTypeName
fullTypeNameOf :: forall t. ProperNodeKind t => t -> FullTypeName
fullTypeNameOf t
t = (Proxy t -> KindName
forall t. ProperNodeKind t => Proxy t -> KindName
kindNameOf (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t), t -> TypeName
forall t. ProperNodeKind t => t -> TypeName
typeNameOf t
t)

properTypeMetaOf :: (ProperNodeKind t) => t -> ProperTypeMeta
properTypeMetaOf :: forall t. ProperNodeKind t => t -> ProperTypeMeta
properTypeMetaOf t
t =
    DisplayTypeName -> TreeSyntax FullTypeName -> ProperTypeMeta
ProperTypeMeta
        (t -> DisplayTypeName
forall t. ProperNodeKind t => t -> DisplayTypeName
displayTypeNameOf t
t)
        ((forall t. ProperNodeKind t => t -> FullTypeName)
-> t -> TreeSyntax FullTypeName
forall t a.
ProperNodeKind t =>
(forall t'. ProperNodeKind t' => t' -> a) -> t -> TreeSyntax a
forall a.
(forall t'. ProperNodeKind t' => t' -> a) -> t -> TreeSyntax a
treeSyntaxMap t' -> FullTypeName
forall t. ProperNodeKind t => t -> FullTypeName
fullTypeNameOf t
t)

properChildrenTypeMap
    :: (ProperNodeKind t)
    => (forall t'. (ProperNodeKind t') => t' -> a)
    -> t
    -> [a]
properChildrenTypeMap :: forall t a.
ProperNodeKind t =>
(forall t'. ProperNodeKind t' => t' -> a) -> t -> [a]
properChildrenTypeMap forall t'. ProperNodeKind t' => t' -> a
f t
t =
    case (forall t'. ProperNodeKind t' => t' -> a) -> t -> TreeSyntax a
forall t a.
ProperNodeKind t =>
(forall t'. ProperNodeKind t' => t' -> a) -> t -> TreeSyntax a
forall a.
(forall t'. ProperNodeKind t' => t' -> a) -> t -> TreeSyntax a
treeSyntaxMap t' -> a
forall t'. ProperNodeKind t' => t' -> a
f t
t of
        TreeSyntax a
LeafSyntax -> []
        TreeSyntax HasEditableHeader
_ (SequenceOrder [Disjunction a]
ts') -> (Disjunction a -> [a]) -> [Disjunction a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Disjunction a -> [a]
forall {a}. Disjunction a -> [a]
aux [Disjunction a]
ts'
        TreeSyntax HasEditableHeader
_ (StarOrder Disjunction a
t') -> Disjunction a -> [a]
forall {a}. Disjunction a -> [a]
aux Disjunction a
t'
  where
    aux :: Disjunction a -> [a]
aux (Disjunction [a]
ts') = [a]
ts'

-- | Collect information on proper (see 'ProperNodeKind') tree types
--   recursively.
--   This should generally be applied to roots of the type tree; that is, to
--   'Language.Lsd.AST.Type.DocumentContainerType's.
properTypeCollect
    :: (ProperNodeKind t, Ord k)
    => (forall t'. (ProperNodeKind t') => t' -> (k, v))
    -> t
    -> Map k v
properTypeCollect :: forall t k v.
(ProperNodeKind t, Ord k) =>
(forall t'. ProperNodeKind t' => t' -> (k, v)) -> t -> Map k v
properTypeCollect forall t'. ProperNodeKind t' => t' -> (k, v)
f = CollectionState k v () -> Map k v
forall k v. CollectionState k v () -> Map k v
execCollectionState (CollectionState k v () -> Map k v)
-> (t -> CollectionState k v ()) -> t -> Map k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall t'. ProperNodeKind t' => t' -> (k, v))
-> t -> CollectionState k v ()
forall t k v.
(ProperNodeKind t, Ord k) =>
(forall t'. ProperNodeKind t' => t' -> (k, v))
-> t -> CollectionState k v ()
aux t' -> (k, v)
forall t'. ProperNodeKind t' => t' -> (k, v)
f
  where
    aux
        :: (ProperNodeKind t, Ord k)
        => (forall t'. (ProperNodeKind t') => t' -> (k, v))
        -> t
        -> CollectionState k v ()
    aux :: forall t k v.
(ProperNodeKind t, Ord k) =>
(forall t'. ProperNodeKind t' => t' -> (k, v))
-> t -> CollectionState k v ()
aux forall t'. ProperNodeKind t' => t' -> (k, v)
f' t
t =
        let (k
k, v
v) = t -> (k, v)
forall t'. ProperNodeKind t' => t' -> (k, v)
f' t
t
         in k -> CollectionState k v v -> CollectionState k v ()
forall k v.
Ord k =>
k -> CollectionState k v v -> CollectionState k v ()
collect k
k (CollectionState k v v -> CollectionState k v ())
-> CollectionState k v v -> CollectionState k v ()
forall a b. (a -> b) -> a -> b
$ v
v v -> CollectionState k v [()] -> CollectionState k v v
forall a b. a -> CollectionState k v b -> CollectionState k v a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [CollectionState k v ()] -> CollectionState k v [()]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((forall t'. ProperNodeKind t' => t' -> CollectionState k v ())
-> t -> [CollectionState k v ()]
forall t a.
ProperNodeKind t =>
(forall t'. ProperNodeKind t' => t' -> a) -> t -> [a]
properChildrenTypeMap ((forall t'. ProperNodeKind t' => t' -> (k, v))
-> t' -> CollectionState k v ()
forall t k v.
(ProperNodeKind t, Ord k) =>
(forall t'. ProperNodeKind t' => t' -> (k, v))
-> t -> CollectionState k v ()
aux t' -> (k, v)
forall t'. ProperNodeKind t' => t' -> (k, v)
f') t
t)

-- | Specialized variant of `properTypeCollect`.
properTypeCollect'
    :: (ProperNodeKind t)
    => (forall t'. (ProperNodeKind t') => t' -> v)
    -> t
    -> Map FullTypeName v
properTypeCollect' :: forall t v.
ProperNodeKind t =>
(forall t'. ProperNodeKind t' => t' -> v)
-> t -> Map FullTypeName v
properTypeCollect' forall t'. ProperNodeKind t' => t' -> v
f = (forall t'. ProperNodeKind t' => t' -> (FullTypeName, v))
-> t -> Map FullTypeName v
forall t k v.
(ProperNodeKind t, Ord k) =>
(forall t'. ProperNodeKind t' => t' -> (k, v)) -> t -> Map k v
properTypeCollect (\t'
t' -> (t' -> FullTypeName
forall t. ProperNodeKind t => t -> FullTypeName
fullTypeNameOf t'
t', t' -> v
forall t'. ProperNodeKind t' => t' -> v
f t'
t'))