module Language.Ltml.Tree.ToMeta
    ( MetaError (..)
    , treeToMeta
    )
where

import Control.Functor.Utils (traverseF)
import Control.Monad.ConsumableStack
    ( ConsumableStack
    , ConsumableStackError
        ( ConsumableStackDepletedEarly
        , ConsumableStackNotFullyConsumed
        )
    , pop
    , runConsumableStack
    )
import Data.Bifunctor (first)
import Data.List (find)
import Data.Map (Map)
import Language.Lsd.AST.Common (FullTypeName)
import Language.Lsd.AST.Type
    ( ProperTypeMeta
    , fullTypeNameOf
    )
import Language.Lsd.Example (availableLSDs)
import Language.Lsd.ToMetaMap (buildMetaMap)
import Language.Ltml.Common (Flagged (Flagged))
import Language.Ltml.HTML (renderTocList)
import Language.Ltml.HTML.Common (RenderedTocEntry)
import Language.Ltml.Tree
    ( FlaggedInputTree
    , FlaggedMetaTree
    , InputTree
    , MetaTree
    , Tree (Leaf, Tree)
    , TypedInputTree
    , TypedMetaTree
    , TypedTree (TypedTree)
    , flaggedTreeMap
    )
import Language.Ltml.Tree.Parser (TreeError)
import Language.Ltml.Tree.ToLtml (treeToLtml)
import Prelude hiding (lookup)

data MetaError
    = MetaBug String
    | MetaTreeError TreeError
    deriving (Int -> MetaError -> ShowS
[MetaError] -> ShowS
MetaError -> String
(Int -> MetaError -> ShowS)
-> (MetaError -> String)
-> ([MetaError] -> ShowS)
-> Show MetaError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MetaError -> ShowS
showsPrec :: Int -> MetaError -> ShowS
$cshow :: MetaError -> String
show :: MetaError -> String
$cshowList :: [MetaError] -> ShowS
showList :: [MetaError] -> ShowS
Show)

-- | Build metadata, to be sent to the frontend.
treeToMeta
    :: FlaggedInputTree ident
    -> Either
        MetaError
        ( FlaggedMetaTree ident
        , Map FullTypeName ProperTypeMeta
        )
treeToMeta :: forall ident.
FlaggedInputTree ident
-> Either
     MetaError (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
treeToMeta FlaggedInputTree ident
tree = do
    Flagged' DocumentContainer
ast <- (TreeError -> MetaError)
-> Either TreeError (Flagged' DocumentContainer)
-> Either MetaError (Flagged' DocumentContainer)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TreeError -> MetaError
MetaTreeError (Either TreeError (Flagged' DocumentContainer)
 -> Either MetaError (Flagged' DocumentContainer))
-> Either TreeError (Flagged' DocumentContainer)
-> Either MetaError (Flagged' DocumentContainer)
forall a b. (a -> b) -> a -> b
$ FlaggedInputTree' -> Either TreeError (Flagged' DocumentContainer)
treeToLtml FlaggedInputTree'
tree'
    let headings :: [RenderedTocEntry]
headings = Flagged' DocumentContainer -> [RenderedTocEntry]
renderTocList Flagged' DocumentContainer
ast
    (String -> MetaError)
-> Either
     String (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
-> Either
     MetaError (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> MetaError
MetaBug (Either
   String (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
 -> Either
      MetaError (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta))
-> Either
     String (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
-> Either
     MetaError (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
forall a b. (a -> b) -> a -> b
$ [RenderedTocEntry]
-> FlaggedInputTree ident
-> Either
     String (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
forall ident.
[RenderedTocEntry]
-> FlaggedInputTree ident
-> Either
     String (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
buildMeta' [RenderedTocEntry]
headings FlaggedInputTree ident
tree
  where
    tree' :: FlaggedInputTree Bool
    tree' :: FlaggedInputTree'
tree' = (ident -> Bool)
-> (Maybe Text -> Maybe Text)
-> (Text -> Text)
-> FlaggedInputTree ident
-> FlaggedInputTree'
forall fl fl' a a' b b'.
(fl -> fl')
-> (a -> a')
-> (b -> b')
-> FlaggedTree fl a b
-> FlaggedTree fl' a' b'
flaggedTreeMap (Bool -> ident -> Bool
forall a b. a -> b -> a
const Bool
dummyFlag) Maybe Text -> Maybe Text
forall a. a -> a
id Text -> Text
forall a. a -> a
id FlaggedInputTree ident
tree
      where
        dummyFlag :: Bool
dummyFlag = Bool
True -- ignored; should never be evaluated

-- | Build metadata, based on a list of headings and a tree.
--   Headings must be given in pre-order.
--   Returns @Left msg@ on an error, which is never a user error, but rather a
--   bug.
--   This does not fully check the validity of the input tree, which is done
--   elsewhere (specifically, by 'Language.Ltml.Tree.ToLtml.treeToLtml').
buildMeta'
    :: [RenderedTocEntry]
    -> FlaggedInputTree ident
    -> Either String (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
buildMeta' :: forall ident.
[RenderedTocEntry]
-> FlaggedInputTree ident
-> Either
     String (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
buildMeta' [RenderedTocEntry]
hs FlaggedInputTree ident
tree =
    (,)
        (FlaggedMetaTree ident
 -> Map FullTypeName ProperTypeMeta
 -> (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta))
-> Either String (FlaggedMetaTree ident)
-> Either
     String
     (Map FullTypeName ProperTypeMeta
      -> (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RenderedTocEntry]
-> FlaggedInputTree ident -> Either String (FlaggedMetaTree ident)
forall ident.
[RenderedTocEntry]
-> FlaggedInputTree ident -> Either String (FlaggedMetaTree ident)
buildMetaTree [RenderedTocEntry]
hs FlaggedInputTree ident
tree
        Either
  String
  (Map FullTypeName ProperTypeMeta
   -> (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta))
-> Either String (Map FullTypeName ProperTypeMeta)
-> Either
     String (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (NamedType DocumentContainerType -> Map FullTypeName ProperTypeMeta
buildMetaMap (NamedType DocumentContainerType
 -> Map FullTypeName ProperTypeMeta)
-> Either String (NamedType DocumentContainerType)
-> Either String (Map FullTypeName ProperTypeMeta)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FlaggedInputTree ident
-> Either String (NamedType DocumentContainerType)
forall {flag} {flag} {a} {b}.
Flagged flag (TypedTree flag a b)
-> Either String (NamedType DocumentContainerType)
getRootType FlaggedInputTree ident
tree)
  where
    getRootType :: Flagged flag (TypedTree flag a b)
-> Either String (NamedType DocumentContainerType)
getRootType (Flagged flag
_ (TypedTree KindName
kindName TypeName
typeName Tree flag a b
_)) =
        case (NamedType DocumentContainerType -> Bool)
-> [NamedType DocumentContainerType]
-> Maybe (NamedType DocumentContainerType)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((FullTypeName -> FullTypeName -> Bool
forall a. Eq a => a -> a -> Bool
== FullTypeName
fullTypeName) (FullTypeName -> Bool)
-> (NamedType DocumentContainerType -> FullTypeName)
-> NamedType DocumentContainerType
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedType DocumentContainerType -> FullTypeName
forall t. ProperNodeKind t => t -> FullTypeName
fullTypeNameOf) [NamedType DocumentContainerType]
availableLSDs of
            Just NamedType DocumentContainerType
t -> NamedType DocumentContainerType
-> Either String (NamedType DocumentContainerType)
forall a b. b -> Either a b
Right NamedType DocumentContainerType
t
            Maybe (NamedType DocumentContainerType)
Nothing -> String -> Either String (NamedType DocumentContainerType)
forall a b. a -> Either a b
Left (String -> Either String (NamedType DocumentContainerType))
-> String -> Either String (NamedType DocumentContainerType)
forall a b. (a -> b) -> a -> b
$ String
"Unknown type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FullTypeName -> String
forall a. Show a => a -> String
show FullTypeName
fullTypeName
      where
        fullTypeName :: FullTypeName
fullTypeName = (KindName
kindName, TypeName
typeName)

type HeadingStack = ConsumableStack RenderedTocEntry

buildMetaTree
    :: [RenderedTocEntry]
    -> FlaggedInputTree ident
    -> Either String (FlaggedMetaTree ident)
buildMetaTree :: forall ident.
[RenderedTocEntry]
-> FlaggedInputTree ident -> Either String (FlaggedMetaTree ident)
buildMetaTree [RenderedTocEntry]
hs FlaggedInputTree ident
tree0 =
    (ConsumableStackError -> String)
-> Either ConsumableStackError (FlaggedMetaTree ident)
-> Either String (FlaggedMetaTree ident)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ConsumableStackError -> String
prettyError (Either ConsumableStackError (FlaggedMetaTree ident)
 -> Either String (FlaggedMetaTree ident))
-> Either ConsumableStackError (FlaggedMetaTree ident)
-> Either String (FlaggedMetaTree ident)
forall a b. (a -> b) -> a -> b
$ ConsumableStack RenderedTocEntry (FlaggedMetaTree ident)
-> [RenderedTocEntry]
-> Either ConsumableStackError (FlaggedMetaTree ident)
forall s a.
ConsumableStack s a -> [s] -> Either ConsumableStackError a
runConsumableStack (FlaggedInputTree ident
-> ConsumableStack RenderedTocEntry (FlaggedMetaTree ident)
forall ident.
FlaggedInputTree ident -> HeadingStack (FlaggedMetaTree ident)
flaggedTreeF FlaggedInputTree ident
tree0) [RenderedTocEntry]
hs
  where
    prettyError :: ConsumableStackError -> String
prettyError ConsumableStackError
ConsumableStackDepletedEarly = String
"Too few headings"
    prettyError ConsumableStackError
ConsumableStackNotFullyConsumed = String
"Too many headings"

    flaggedTreeF
        :: FlaggedInputTree ident
        -> HeadingStack (FlaggedMetaTree ident)
    flaggedTreeF :: forall ident.
FlaggedInputTree ident -> HeadingStack (FlaggedMetaTree ident)
flaggedTreeF = (TypedTree ident (Maybe Text) Text
 -> ConsumableStackT
      RenderedTocEntry
      Identity
      (TypedTree ident RenderedTocEntry RenderedTocEntry))
-> Flagged ident (TypedTree ident (Maybe Text) Text)
-> ConsumableStackT
     RenderedTocEntry
     Identity
     (Flagged ident (TypedTree ident RenderedTocEntry RenderedTocEntry))
forall (t :: * -> *) (f :: * -> *) a b.
(TraversableF t, Functor f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> Flagged ident a -> f (Flagged ident b)
traverseF TypedTree ident (Maybe Text) Text
-> ConsumableStackT
     RenderedTocEntry
     Identity
     (TypedTree ident RenderedTocEntry RenderedTocEntry)
forall ident.
TypedInputTree ident -> HeadingStack (TypedMetaTree ident)
typedTreeF

    typedTreeF :: TypedInputTree ident -> HeadingStack (TypedMetaTree ident)
    typedTreeF :: forall ident.
TypedInputTree ident -> HeadingStack (TypedMetaTree ident)
typedTreeF (TypedTree KindName
kindName TypeName
typeName Tree ident (Maybe Text) Text
tree) =
        KindName
-> TypeName
-> Tree ident RenderedTocEntry RenderedTocEntry
-> TypedTree ident RenderedTocEntry RenderedTocEntry
forall flag a b.
KindName -> TypeName -> Tree flag a b -> TypedTree flag a b
TypedTree KindName
kindName TypeName
typeName (Tree ident RenderedTocEntry RenderedTocEntry
 -> TypedTree ident RenderedTocEntry RenderedTocEntry)
-> ConsumableStackT
     RenderedTocEntry
     Identity
     (Tree ident RenderedTocEntry RenderedTocEntry)
-> ConsumableStackT
     RenderedTocEntry
     Identity
     (TypedTree ident RenderedTocEntry RenderedTocEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree ident (Maybe Text) Text
-> ConsumableStackT
     RenderedTocEntry
     Identity
     (Tree ident RenderedTocEntry RenderedTocEntry)
forall ident. InputTree ident -> HeadingStack (MetaTree ident)
treeF Tree ident (Maybe Text) Text
tree

    treeF :: InputTree ident -> HeadingStack (MetaTree ident)
    treeF :: forall ident. InputTree ident -> HeadingStack (MetaTree ident)
treeF (Tree Maybe Text
_ [FlaggedTree ident (Maybe Text) Text]
trees) = RenderedTocEntry
-> [FlaggedTree ident RenderedTocEntry RenderedTocEntry]
-> Tree ident RenderedTocEntry RenderedTocEntry
forall flag a b. a -> [FlaggedTree flag a b] -> Tree flag a b
Tree (RenderedTocEntry
 -> [FlaggedTree ident RenderedTocEntry RenderedTocEntry]
 -> Tree ident RenderedTocEntry RenderedTocEntry)
-> ConsumableStackT RenderedTocEntry Identity RenderedTocEntry
-> ConsumableStackT
     RenderedTocEntry
     Identity
     ([FlaggedTree ident RenderedTocEntry RenderedTocEntry]
      -> Tree ident RenderedTocEntry RenderedTocEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConsumableStackT RenderedTocEntry Identity RenderedTocEntry
forall s (m :: * -> *). MonadConsumableStack s m => m s
pop ConsumableStackT
  RenderedTocEntry
  Identity
  ([FlaggedTree ident RenderedTocEntry RenderedTocEntry]
   -> Tree ident RenderedTocEntry RenderedTocEntry)
-> ConsumableStackT
     RenderedTocEntry
     Identity
     [FlaggedTree ident RenderedTocEntry RenderedTocEntry]
-> ConsumableStackT
     RenderedTocEntry
     Identity
     (Tree ident RenderedTocEntry RenderedTocEntry)
forall a b.
ConsumableStackT RenderedTocEntry Identity (a -> b)
-> ConsumableStackT RenderedTocEntry Identity a
-> ConsumableStackT RenderedTocEntry Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FlaggedTree ident (Maybe Text) Text
 -> ConsumableStackT
      RenderedTocEntry
      Identity
      (FlaggedTree ident RenderedTocEntry RenderedTocEntry))
-> [FlaggedTree ident (Maybe Text) Text]
-> ConsumableStackT
     RenderedTocEntry
     Identity
     [FlaggedTree ident RenderedTocEntry RenderedTocEntry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FlaggedTree ident (Maybe Text) Text
-> ConsumableStackT
     RenderedTocEntry
     Identity
     (FlaggedTree ident RenderedTocEntry RenderedTocEntry)
forall ident.
FlaggedInputTree ident -> HeadingStack (FlaggedMetaTree ident)
flaggedTreeF [FlaggedTree ident (Maybe Text) Text]
trees
    treeF (Leaf Text
_) = RenderedTocEntry -> Tree ident RenderedTocEntry RenderedTocEntry
forall flag a b. b -> Tree flag a b
Leaf (RenderedTocEntry -> Tree ident RenderedTocEntry RenderedTocEntry)
-> ConsumableStackT RenderedTocEntry Identity RenderedTocEntry
-> ConsumableStackT
     RenderedTocEntry
     Identity
     (Tree ident RenderedTocEntry RenderedTocEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConsumableStackT RenderedTocEntry Identity RenderedTocEntry
forall s (m :: * -> *). MonadConsumableStack s m => m s
pop