{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Functor law" #-}
module Language.Ltml.Tree.Parser.DocumentContainer
    ( documentContainerTP
    )
where

import Data.Text (Text)
import Language.Lsd.AST.SimpleRegex (Disjunction, Sequence (Sequence))
import Language.Lsd.AST.Type (NamedType)
import Language.Lsd.AST.Type.AppendixSection (AppendixSectionType)
import Language.Lsd.AST.Type.DocumentContainer
    ( DocumentContainerType (DocumentContainerType)
    )
import Language.Ltml.AST.AppendixSection (AppendixSection)
import Language.Ltml.AST.DocumentContainer
    ( DocumentContainer (DocumentContainer)
    , DocumentContainerHeader
    )
import Language.Ltml.Common (Flagged', NavTocHeaded (NavTocHeaded), Parsed)
import Language.Ltml.Parser.DocumentContainer (documentContainerHeaderP)
import Language.Ltml.Tree (FlaggedInputTree', InputTree', Tree (Leaf, Tree))
import Language.Ltml.Tree.Parser
    ( TreeParser
    , disjNFlaggedTreePF
    , leafParser
    )
import Language.Ltml.Tree.Parser.AppendixSection (appendixSectionTP)
import Language.Ltml.Tree.Parser.Document (documentTP)

documentContainerTP
    :: Disjunction (NamedType DocumentContainerType)
    -> FlaggedInputTree'
    -> TreeParser (Flagged' DocumentContainer)
documentContainerTP :: Disjunction (NamedType DocumentContainerType)
-> FlaggedInputTree' -> TreeParser (Flagged' DocumentContainer)
documentContainerTP = (DocumentContainerType
 -> Tree Bool (Maybe Text) Text -> TreeParser DocumentContainer)
-> Disjunction (NamedType DocumentContainerType)
-> FlaggedInputTree'
-> TreeParser (Flagged' DocumentContainer)
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 DocumentContainerType
-> Tree Bool (Maybe Text) Text -> TreeParser DocumentContainer
aux
  where
    aux :: DocumentContainerType -> InputTree' -> TreeParser DocumentContainer
    aux :: DocumentContainerType
-> Tree Bool (Maybe Text) Text -> TreeParser DocumentContainer
aux DocumentContainerType
_ (Leaf Text
_) = String -> TreeParser DocumentContainer
forall a. String -> TreeParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Document container node is leaf"
    aux DocumentContainerType
_ (Tree Maybe Text
_ []) = String -> TreeParser DocumentContainer
forall a. String -> TreeParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Document container lacks main document child"
    aux
        (DocumentContainerType DocumentContainerFormat
fmt NavTocHeading
nth NamedType DocumentType
mainDocT Sequence (NamedType AppendixSectionType)
appsT)
        (Tree Maybe Text
x (FlaggedInputTree'
mainDocTree : [FlaggedInputTree']
trees)) =
            DocumentContainerFormat
-> NavTocHeaded (Parsed DocumentContainerHeader)
-> Flagged' Document
-> [Flagged' AppendixSection]
-> DocumentContainer
DocumentContainer DocumentContainerFormat
fmt
                (NavTocHeaded (Parsed DocumentContainerHeader)
 -> Flagged' Document
 -> [Flagged' AppendixSection]
 -> DocumentContainer)
-> TreeParser (NavTocHeaded (Parsed DocumentContainerHeader))
-> TreeParser
     (Flagged' Document
      -> [Flagged' AppendixSection] -> DocumentContainer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NavTocHeading
-> Parsed DocumentContainerHeader
-> NavTocHeaded (Parsed DocumentContainerHeader)
forall a. NavTocHeading -> a -> NavTocHeaded a
NavTocHeaded NavTocHeading
nth (Parsed DocumentContainerHeader
 -> NavTocHeaded (Parsed DocumentContainerHeader))
-> TreeParser (Parsed DocumentContainerHeader)
-> TreeParser (NavTocHeaded (Parsed DocumentContainerHeader))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> TreeParser (Parsed DocumentContainerHeader)
headerTP Maybe Text
x)
                TreeParser
  (Flagged' Document
   -> [Flagged' AppendixSection] -> DocumentContainer)
-> TreeParser (Flagged' Document)
-> TreeParser ([Flagged' AppendixSection] -> DocumentContainer)
forall a b. TreeParser (a -> b) -> TreeParser a -> TreeParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamedType DocumentType
-> FlaggedInputTree' -> TreeParser (Flagged' Document)
documentTP NamedType DocumentType
mainDocT FlaggedInputTree'
mainDocTree
                TreeParser ([Flagged' AppendixSection] -> DocumentContainer)
-> TreeParser [Flagged' AppendixSection]
-> TreeParser DocumentContainer
forall a b. TreeParser (a -> b) -> TreeParser a -> TreeParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Sequence (NamedType AppendixSectionType)
-> [FlaggedInputTree'] -> TreeParser [Flagged' AppendixSection]
appendicesTP Sequence (NamedType AppendixSectionType)
appsT [FlaggedInputTree']
trees

headerTP :: Maybe Text -> TreeParser (Parsed DocumentContainerHeader)
headerTP :: Maybe Text -> TreeParser (Parsed DocumentContainerHeader)
headerTP Maybe Text
Nothing = String -> TreeParser (Parsed DocumentContainerHeader)
forall a. String -> TreeParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Document container lacks header"
headerTP (Just Text
x) = Parser DocumentContainerHeader
-> Text -> TreeParser (Parsed DocumentContainerHeader)
forall a. Parser a -> Text -> TreeParser (Parsed a)
leafParser Parser DocumentContainerHeader
documentContainerHeaderP Text
x

appendicesTP
    :: Sequence (NamedType AppendixSectionType)
    -> [FlaggedInputTree']
    -> TreeParser [Flagged' AppendixSection]
appendicesTP :: Sequence (NamedType AppendixSectionType)
-> [FlaggedInputTree'] -> TreeParser [Flagged' AppendixSection]
appendicesTP (Sequence [NamedType AppendixSectionType]
ts) [FlaggedInputTree']
tTrees =
    case (NamedType AppendixSectionType
 -> FlaggedInputTree' -> TreeParser (Flagged' AppendixSection))
-> [NamedType AppendixSectionType]
-> [FlaggedInputTree']
-> Maybe [TreeParser (Flagged' AppendixSection)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> Maybe [c]
safeZipWith NamedType AppendixSectionType
-> FlaggedInputTree' -> TreeParser (Flagged' AppendixSection)
appendixSectionTP [NamedType AppendixSectionType]
ts [FlaggedInputTree']
tTrees of
        Maybe [TreeParser (Flagged' AppendixSection)]
Nothing -> String -> TreeParser [Flagged' AppendixSection]
forall a. String -> TreeParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong number of appendix sections"
        Just [TreeParser (Flagged' AppendixSection)]
apps -> [TreeParser (Flagged' AppendixSection)]
-> TreeParser [Flagged' AppendixSection]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [TreeParser (Flagged' AppendixSection)]
apps

safeZipWith :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
safeZipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> Maybe [c]
safeZipWith a -> b -> c
_ [] [] = [c] -> Maybe [c]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return []
safeZipWith a -> b -> c
f (a
x : [a]
xs) (b
y : [b]
ys) = (a -> b -> c
f a
x b
y c -> [c] -> [c]
forall a. a -> [a] -> [a]
:) ([c] -> [c]) -> Maybe [c] -> Maybe [c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> b -> c) -> [a] -> [b] -> Maybe [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> Maybe [c]
safeZipWith a -> b -> c
f [a]
xs [b]
ys
safeZipWith a -> b -> c
_ [a]
_ [b]
_ = Maybe [c]
forall a. Maybe a
Nothing