{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Language.Ltml.Tree.Parser
    ( TreeParser
    , FootnoteTreeParser
    , runTreeParser
    , MonadTreeParser (treeParser)
    , TreeError (..)
    , leafParser
    , leafFootnoteParser
    , flaggedTreePF
    , nFlaggedTreePF
    , disjFlaggedTreePF
    , disjNFlaggedTreePF
    )
where

import Control.Functor.Utils (traverseF)
import Control.Monad.Trans.Class (lift)
import Data.List (find)
import Data.Proxy (Proxy (Proxy))
import Data.Text (Text)
import Language.Lsd.AST.Common (TypeName)
import Language.Lsd.AST.SimpleRegex (Disjunction (Disjunction))
import Language.Lsd.AST.Type
    ( NamedType
    , ProperNodeKind (kindNameOf, typeNameOf)
    , RawProperNodeKind
    , unwrapNT
    )
import Language.Ltml.Common (Flagged, Parsed)
import Language.Ltml.Parser (Parser)
import Language.Ltml.Parser.Common.Lexeme (nSc)
import Language.Ltml.Parser.Footnote
    ( FootnoteParser
    , FootnoteWriterT
    , eitherMapFootnoteWriterT
    )
import Language.Ltml.Tree (FlaggedTree, Tree, TypedTree (TypedTree))
import Text.Megaparsec (eof, runParser)

newtype TreeParser a = TreeParser (Either TreeError a)
    deriving ((forall a b. (a -> b) -> TreeParser a -> TreeParser b)
-> (forall a b. a -> TreeParser b -> TreeParser a)
-> Functor TreeParser
forall a b. a -> TreeParser b -> TreeParser a
forall a b. (a -> b) -> TreeParser a -> TreeParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TreeParser a -> TreeParser b
fmap :: forall a b. (a -> b) -> TreeParser a -> TreeParser b
$c<$ :: forall a b. a -> TreeParser b -> TreeParser a
<$ :: forall a b. a -> TreeParser b -> TreeParser a
Functor, Functor TreeParser
Functor TreeParser =>
(forall a. a -> TreeParser a)
-> (forall a b.
    TreeParser (a -> b) -> TreeParser a -> TreeParser b)
-> (forall a b c.
    (a -> b -> c) -> TreeParser a -> TreeParser b -> TreeParser c)
-> (forall a b. TreeParser a -> TreeParser b -> TreeParser b)
-> (forall a b. TreeParser a -> TreeParser b -> TreeParser a)
-> Applicative TreeParser
forall a. a -> TreeParser a
forall a b. TreeParser a -> TreeParser b -> TreeParser a
forall a b. TreeParser a -> TreeParser b -> TreeParser b
forall a b. TreeParser (a -> b) -> TreeParser a -> TreeParser b
forall a b c.
(a -> b -> c) -> TreeParser a -> TreeParser b -> TreeParser c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> TreeParser a
pure :: forall a. a -> TreeParser a
$c<*> :: forall a b. TreeParser (a -> b) -> TreeParser a -> TreeParser b
<*> :: forall a b. TreeParser (a -> b) -> TreeParser a -> TreeParser b
$cliftA2 :: forall a b c.
(a -> b -> c) -> TreeParser a -> TreeParser b -> TreeParser c
liftA2 :: forall a b c.
(a -> b -> c) -> TreeParser a -> TreeParser b -> TreeParser c
$c*> :: forall a b. TreeParser a -> TreeParser b -> TreeParser b
*> :: forall a b. TreeParser a -> TreeParser b -> TreeParser b
$c<* :: forall a b. TreeParser a -> TreeParser b -> TreeParser a
<* :: forall a b. TreeParser a -> TreeParser b -> TreeParser a
Applicative, Applicative TreeParser
Applicative TreeParser =>
(forall a b. TreeParser a -> (a -> TreeParser b) -> TreeParser b)
-> (forall a b. TreeParser a -> TreeParser b -> TreeParser b)
-> (forall a. a -> TreeParser a)
-> Monad TreeParser
forall a. a -> TreeParser a
forall a b. TreeParser a -> TreeParser b -> TreeParser b
forall a b. TreeParser a -> (a -> TreeParser b) -> TreeParser b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. TreeParser a -> (a -> TreeParser b) -> TreeParser b
>>= :: forall a b. TreeParser a -> (a -> TreeParser b) -> TreeParser b
$c>> :: forall a b. TreeParser a -> TreeParser b -> TreeParser b
>> :: forall a b. TreeParser a -> TreeParser b -> TreeParser b
$creturn :: forall a. a -> TreeParser a
return :: forall a. a -> TreeParser a
Monad)

runTreeParser :: TreeParser a -> Either TreeError a
runTreeParser :: forall a. TreeParser a -> Either TreeError a
runTreeParser (TreeParser Either TreeError a
x) = Either TreeError a
x

class (MonadFail m) => MonadTreeParser m where
    treeParser :: Either TreeError a -> m a

instance MonadFail TreeParser where
    fail :: forall a. String -> TreeParser a
fail = Either TreeError a -> TreeParser a
forall a. Either TreeError a -> TreeParser a
TreeParser (Either TreeError a -> TreeParser a)
-> (String -> Either TreeError a) -> String -> TreeParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeError -> Either TreeError a
forall a b. a -> Either a b
Left (TreeError -> Either TreeError a)
-> (String -> TreeError) -> String -> Either TreeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TreeError
TreeError

instance MonadTreeParser TreeParser where
    treeParser :: forall a. Either TreeError a -> TreeParser a
treeParser = Either TreeError a -> TreeParser a
forall a. Either TreeError a -> TreeParser a
TreeParser

-- | An error that occurred parsing a tree's structure (not input text).
--   The frontend should prohibit such errors, and thus treat such errors as
--   internal / as bugs.
newtype TreeError = TreeError String
    deriving (Int -> TreeError -> ShowS
[TreeError] -> ShowS
TreeError -> String
(Int -> TreeError -> ShowS)
-> (TreeError -> String)
-> ([TreeError] -> ShowS)
-> Show TreeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TreeError -> ShowS
showsPrec :: Int -> TreeError -> ShowS
$cshow :: TreeError -> String
show :: TreeError -> String
$cshowList :: [TreeError] -> ShowS
showList :: [TreeError] -> ShowS
Show)

type FootnoteTreeParser = FootnoteWriterT TreeParser

instance (MonadTreeParser m) => MonadTreeParser (FootnoteWriterT m) where
    treeParser :: forall a. Either TreeError a -> FootnoteWriterT m a
treeParser = m a -> FootnoteWriterT m a
forall (m :: * -> *) a. Monad m => m a -> FootnoteWriterT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> FootnoteWriterT m a)
-> (Either TreeError a -> m a)
-> Either TreeError a
-> FootnoteWriterT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either TreeError a -> m a
forall a. Either TreeError a -> m a
forall (m :: * -> *) a.
MonadTreeParser m =>
Either TreeError a -> m a
treeParser

parseLeaf :: Parser a -> Text -> Parsed a
parseLeaf :: forall a. Parser a -> Text -> Parsed a
parseLeaf Parser a
p Text
x = Parser a -> String -> Text -> Either (ParseErrorBundle Text Void) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (ParsecT Void Text Identity ()
forall (m :: * -> *). MonadParser m => m ()
nSc ParsecT Void Text Identity () -> Parser a -> Parser a
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> ParsecT Void Text Identity () -> Parser a
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"" (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n")

leafParser :: Parser a -> Text -> TreeParser (Parsed a)
leafParser :: forall a. Parser a -> Text -> TreeParser (Parsed a)
leafParser Parser a
p Text
x = Parsed a -> TreeParser (Parsed a)
forall a. a -> TreeParser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parsed a -> TreeParser (Parsed a))
-> Parsed a -> TreeParser (Parsed a)
forall a b. (a -> b) -> a -> b
$ Parser a -> Text -> Parsed a
forall a. Parser a -> Text -> Parsed a
parseLeaf Parser a
p Text
x

{-# ANN
    leafFootnoteParser
    ("HLint: ignore Avoid lambda using `infix`" :: String)
    #-}
leafFootnoteParser :: FootnoteParser a -> Text -> FootnoteTreeParser (Parsed a)
leafFootnoteParser :: forall a. FootnoteParser a -> Text -> FootnoteTreeParser (Parsed a)
leafFootnoteParser FootnoteParser a
p Text
x = (ParsecT Void Text Identity (a, FootnoteMap)
 -> Either (ParseErrorBundle Text Void) (a, FootnoteMap))
-> FootnoteParser a
-> FootnoteWriterT
     TreeParser (Either (ParseErrorBundle Text Void) a)
forall (n :: * -> *) (m :: * -> *) a e b.
Monad n =>
(m (a, FootnoteMap) -> Either e (b, FootnoteMap))
-> FootnoteWriterT m a -> FootnoteWriterT n (Either e b)
eitherMapFootnoteWriterT (\ParsecT Void Text Identity (a, FootnoteMap)
p' -> ParsecT Void Text Identity (a, FootnoteMap)
-> Text -> Either (ParseErrorBundle Text Void) (a, FootnoteMap)
forall a. Parser a -> Text -> Parsed a
parseLeaf ParsecT Void Text Identity (a, FootnoteMap)
p' Text
x) FootnoteParser a
p

flaggedTreePF'
    :: (MonadTreeParser m, ProperNodeKind t)
    => (TypeName -> Maybe (Tree flag a b -> m c))
    -> Proxy t
    -> FlaggedTree flag a b
    -> m (Flagged flag c)
flaggedTreePF' :: forall (m :: * -> *) t flag a b c.
(MonadTreeParser m, ProperNodeKind t) =>
(TypeName -> Maybe (Tree flag a b -> m c))
-> Proxy t -> FlaggedTree flag a b -> m (Flagged flag c)
flaggedTreePF' TypeName -> Maybe (Tree flag a b -> m c)
f Proxy t
kind = (TypedTree flag a b -> m c)
-> Flagged flag (TypedTree flag a b) -> m (Flagged flag c)
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 flag a -> f (Flagged flag b)
traverseF TypedTree flag a b -> m c
aux
  where
    aux :: TypedTree flag a b -> m c
aux (TypedTree KindName
kindName TypeName
typeName Tree flag a b
tree) =
        if KindName
kindName KindName -> KindName -> Bool
forall a. Eq a => a -> a -> Bool
/= Proxy t -> KindName
forall t. ProperNodeKind t => Proxy t -> KindName
kindNameOf Proxy t
kind
            then String -> m c
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m c) -> String -> m c
forall a b. (a -> b) -> a -> b
$ String
"Invalid kind " String -> ShowS
forall a. [a] -> [a] -> [a]
++ KindName -> String
forall a. Show a => a -> String
show KindName
kindName
            else case TypeName -> Maybe (Tree flag a b -> m c)
f TypeName
typeName of
                Maybe (Tree flag a b -> m c)
Nothing -> String -> m c
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m c) -> String -> m c
forall a b. (a -> b) -> a -> b
$ String
"Invalid type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall a. Show a => a -> String
show TypeName
typeName
                Just Tree flag a b -> m c
f' -> Tree flag a b -> m c
f' Tree flag a b
tree

flaggedTreePF
    :: forall m t flag a b c
     . (MonadTreeParser m, ProperNodeKind t)
    => (t -> Tree flag a b -> m c)
    -> t
    -> FlaggedTree flag a b
    -> m (Flagged flag c)
flaggedTreePF :: forall (m :: * -> *) t flag a b c.
(MonadTreeParser m, ProperNodeKind t) =>
(t -> Tree flag a b -> m c)
-> t -> FlaggedTree flag a b -> m (Flagged flag c)
flaggedTreePF t -> Tree flag a b -> m c
f t
t = (TypeName -> Maybe (Tree flag a b -> m c))
-> Proxy t -> FlaggedTree flag a b -> m (Flagged flag c)
forall (m :: * -> *) t flag a b c.
(MonadTreeParser m, ProperNodeKind t) =>
(TypeName -> Maybe (Tree flag a b -> m c))
-> Proxy t -> FlaggedTree flag a b -> m (Flagged flag c)
flaggedTreePF' TypeName -> Maybe (Tree flag a b -> m c)
f' (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t)
  where
    f' :: TypeName -> Maybe (Tree flag a b -> m c)
f' TypeName
typeName =
        if TypeName
typeName TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== t -> TypeName
forall t. ProperNodeKind t => t -> TypeName
typeNameOf t
t
            then (Tree flag a b -> m c) -> Maybe (Tree flag a b -> m c)
forall a. a -> Maybe a
Just ((Tree flag a b -> m c) -> Maybe (Tree flag a b -> m c))
-> (Tree flag a b -> m c) -> Maybe (Tree flag a b -> m c)
forall a b. (a -> b) -> a -> b
$ t -> Tree flag a b -> m c
f t
t
            else Maybe (Tree flag a b -> m c)
forall a. Maybe a
Nothing

nFlaggedTreePF
    :: (MonadTreeParser m, RawProperNodeKind t)
    => (t -> Tree flag a b -> m c)
    -> NamedType t
    -> FlaggedTree flag a b
    -> m (Flagged flag c)
nFlaggedTreePF :: forall (m :: * -> *) t flag a b c.
(MonadTreeParser m, RawProperNodeKind t) =>
(t -> Tree flag a b -> m c)
-> NamedType t -> FlaggedTree flag a b -> m (Flagged flag c)
nFlaggedTreePF t -> Tree flag a b -> m c
f = (NamedType t -> Tree flag a b -> m c)
-> NamedType t -> FlaggedTree flag a b -> m (Flagged flag c)
forall (m :: * -> *) t flag a b c.
(MonadTreeParser m, ProperNodeKind t) =>
(t -> Tree flag a b -> m c)
-> t -> FlaggedTree flag a b -> m (Flagged flag c)
flaggedTreePF (t -> Tree flag a b -> m c
f (t -> Tree flag a b -> m c)
-> (NamedType t -> t) -> NamedType t -> Tree flag a b -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedType t -> t
forall t. NamedType t -> t
unwrapNT)

disjFlaggedTreePF
    :: forall m t flag a b c
     . (MonadTreeParser m, ProperNodeKind t)
    => (t -> Tree flag a b -> m c)
    -> Disjunction t
    -> FlaggedTree flag a b
    -> m (Flagged flag c)
disjFlaggedTreePF :: forall (m :: * -> *) t flag a b c.
(MonadTreeParser m, ProperNodeKind t) =>
(t -> Tree flag a b -> m c)
-> Disjunction t -> FlaggedTree flag a b -> m (Flagged flag c)
disjFlaggedTreePF t -> Tree flag a b -> m c
f (Disjunction [t]
ts) = (TypeName -> Maybe (Tree flag a b -> m c))
-> Proxy t -> FlaggedTree flag a b -> m (Flagged flag c)
forall (m :: * -> *) t flag a b c.
(MonadTreeParser m, ProperNodeKind t) =>
(TypeName -> Maybe (Tree flag a b -> m c))
-> Proxy t -> FlaggedTree flag a b -> m (Flagged flag c)
flaggedTreePF' TypeName -> Maybe (Tree flag a b -> m c)
f' (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t)
  where
    f' :: TypeName -> Maybe (Tree flag a b -> m c)
f' TypeName
typeName = t -> Tree flag a b -> m c
f (t -> Tree flag a b -> m c)
-> Maybe t -> Maybe (Tree flag a b -> m c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (t -> Bool) -> [t] -> Maybe t
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((TypeName
typeName TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
==) (TypeName -> Bool) -> (t -> TypeName) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> TypeName
forall t. ProperNodeKind t => t -> TypeName
typeNameOf) [t]
ts

disjNFlaggedTreePF
    :: (MonadTreeParser m, RawProperNodeKind t)
    => (t -> Tree flag a b -> m c)
    -> Disjunction (NamedType t)
    -> FlaggedTree flag a b
    -> m (Flagged flag c)
disjNFlaggedTreePF :: forall (m :: * -> *) t flag a b c.
(MonadTreeParser m, RawProperNodeKind t) =>
(t -> Tree flag a b -> m c)
-> Disjunction (NamedType t)
-> FlaggedTree flag a b
-> m (Flagged flag c)
disjNFlaggedTreePF t -> Tree flag a b -> m c
f = (NamedType t -> Tree flag a b -> m c)
-> Disjunction (NamedType t)
-> FlaggedTree flag a b
-> m (Flagged flag c)
forall (m :: * -> *) t flag a b c.
(MonadTreeParser m, ProperNodeKind t) =>
(t -> Tree flag a b -> m c)
-> Disjunction t -> FlaggedTree flag a b -> m (Flagged flag c)
disjFlaggedTreePF (t -> Tree flag a b -> m c
f (t -> Tree flag a b -> m c)
-> (NamedType t -> t) -> NamedType t -> Tree flag a b -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedType t -> t
forall t. NamedType t -> t
unwrapNT)