{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Ltml.Parser.Module (moduleBlockP, moduleP) where

import Data.Void (Void)
import Language.Lsd.AST.Common (Keyword)
import Language.Lsd.AST.Type.Module
    ( CategoryType (..)
    , ModuleBlockType (..)
    , ModuleSchemaType (..)
    , ModuleType (..)
    )
import Language.Lsd.AST.Type.Table (CellFormat)
import Language.Lsd.AST.Type.Text (TextType)
import Language.Ltml.AST.Table (Cell (..), Row (..), Table (..))
import Language.Ltml.Parser (Parser)
import Language.Ltml.Parser.Common.Lexeme (lexeme, nLexeme)
import Language.Ltml.Parser.Keyword (keywordP)
import Language.Ltml.Parser.Text
    ( hangingTextP
    , pipeSeperatedTextForestsP
    )
import Text.Megaparsec (choice, many, some, try, (<?>))

attributeListP :: Keyword -> CellFormat -> TextType Void -> Parser [Cell]
attributeListP :: Keyword -> CellFormat -> TextType Void -> Parser [Cell]
attributeListP Keyword
kw CellFormat
cf TextType Void
tt = do
    ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadParser m => m a -> m a
nLexeme (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Keyword -> ParsecT Void Text Identity ()
forall (m :: * -> *). MonadParser m => Keyword -> m ()
keywordP Keyword
kw
    ([TableTextTree] -> Cell) -> [[TableTextTree]] -> [Cell]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[TableTextTree]
tf -> CellFormat -> [TableTextTree] -> Width -> Width -> Cell
Cell CellFormat
cf [TableTextTree]
tf Width
1 Width
1) ([[TableTextTree]] -> [Cell])
-> ParsecT Void Text Identity [[TableTextTree]] -> Parser [Cell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextType Void -> ParsecT Void Text Identity [[TableTextTree]]
forall (m :: * -> *) lbrk fnref style enumType enum special.
(ParserWrapper m, LineBreakP lbrk, FootnoteRefP fnref,
 StyleP style, EnumP enumType enum, SpecialP m special) =>
TextType enumType -> m [[TextTree lbrk fnref style enum special]]
pipeSeperatedTextForestsP TextType Void
tt

-------------------------------------------------------------------------------

schemaP
    :: ModuleSchemaType -> TextType Void -> Parser Row
schemaP :: ModuleSchemaType -> TextType Void -> Parser Row
schemaP (ModuleSchemaType Keyword
kw CellFormat
cf) TextType Void
tt = [Cell] -> Row
Row ([Cell] -> Row) -> Parser [Cell] -> Parser Row
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Keyword -> CellFormat -> TextType Void -> Parser [Cell]
attributeListP Keyword
kw CellFormat
cf TextType Void
tt Parser Row -> String -> Parser Row
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"module schema"

moduleP :: ModuleType -> TextType Void -> Parser [Cell]
moduleP :: ModuleType -> TextType Void -> Parser [Cell]
moduleP (ModuleType Keyword
kw CellFormat
cf) TextType Void
tt = Keyword -> CellFormat -> TextType Void -> Parser [Cell]
attributeListP Keyword
kw CellFormat
cf TextType Void
tt Parser [Cell] -> String -> Parser [Cell]
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"module"

categoryP :: CategoryType -> TextType Void -> Parser [Row]
categoryP :: CategoryType -> TextType Void -> Parser [Row]
categoryP (CategoryType Keyword
kw CellFormat
cf ModuleType
moduleType) TextType Void
tt = do
    [TableTextTree]
categoryTree <- ParsecT Void Text Identity [TableTextTree]
-> ParsecT Void Text Identity [TableTextTree]
forall (m :: * -> *) a. MonadParser m => m a -> m a
nLexeme (Keyword
-> TextType Void -> ParsecT Void Text Identity [TableTextTree]
forall (m :: * -> *) lbrk fnref style enumType enum special.
(ParserWrapper m, LineBreakP lbrk, FootnoteRefP fnref,
 StyleP style, EnumP enumType enum, SpecialP m special) =>
Keyword
-> TextType enumType -> m [TextTree lbrk fnref style enum special]
hangingTextP Keyword
kw TextType Void
tt)
    [[Cell]]
modules <- Parser [Cell] -> ParsecT Void Text Identity [[Cell]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser [Cell] -> Parser [Cell]
forall (m :: * -> *) a. MonadParser m => m a -> m a
nLexeme (ModuleType -> TextType Void -> Parser [Cell]
moduleP ModuleType
moduleType TextType Void
tt))
    [Row] -> Parser [Row]
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Row] -> Parser [Row]) -> [Row] -> Parser [Row]
forall a b. (a -> b) -> a -> b
$ case [[Cell]]
modules of
        [] -> [[Cell] -> Row
Row [CellFormat -> [TableTextTree] -> Width -> Width -> Cell
Cell CellFormat
cf [TableTextTree]
categoryTree Width
1 Width
1]]
        ([Cell]
m : [[Cell]]
ms) -> [Cell] -> Row
Row (CellFormat -> [TableTextTree] -> Width -> Width -> Cell
Cell CellFormat
cf [TableTextTree]
categoryTree Width
1 ([[Cell]] -> Width
forall a. [a] -> Width
forall (t :: * -> *) a. Foldable t => t a -> Width
length [[Cell]]
modules) Cell -> [Cell] -> [Cell]
forall a. a -> [a] -> [a]
: [Cell]
m) Row -> [Row] -> [Row]
forall a. a -> [a] -> [a]
: ([Cell] -> Row) -> [[Cell]] -> [Row]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Cell] -> Row
Row [[Cell]]
ms

-- | Parse a schema and 0 to n module definitions. The block is terminated by an empty line.
moduleBlockP
    :: ModuleBlockType -> Parser Table
moduleBlockP :: ModuleBlockType -> Parser Table
moduleBlockP
    ( ModuleBlockType
            TextType Void
tt
            schemaType :: ModuleSchemaType
schemaType@(ModuleSchemaType Keyword
_ CellFormat
schemaCellFormat)
            categoryType :: CategoryType
categoryType@(CategoryType Keyword
_ CellFormat
_ ModuleType
moduleType)
        ) = do
        -- categorized has to be tried first (see below)!
        ColumnProps -> [Row] -> Table
Table ColumnProps
forall a. Maybe a
Nothing ([Row] -> Table) -> Parser [Row] -> Parser Table
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Parser [Row]] -> Parser [Row]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Parser [Row] -> Parser [Row]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser [Row]
categorizedP, Parser [Row]
plainP]
      where
        -- If categorized failes (due to the 'some' requirement), we try plain.
        -- Thus, empty categorizeds are not allowed
        categorizedP :: Parser [Row]
        categorizedP :: Parser [Row]
categorizedP = do
            (Row [Cell]
schemaCells) <- Parser Row
lexSchemaP
            [Row]
categoryRows <- [[Row]] -> [Row]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Row]] -> [Row])
-> ParsecT Void Text Identity [[Row]] -> Parser [Row]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Row] -> ParsecT Void Text Identity [[Row]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (Parser [Row] -> Parser [Row]
forall (m :: * -> *) a. MonadParser m => m a -> m a
nLexeme (Parser [Row] -> Parser [Row]) -> Parser [Row] -> Parser [Row]
forall a b. (a -> b) -> a -> b
$ CategoryType -> TextType Void -> Parser [Row]
categoryP CategoryType
categoryType TextType Void
tt)
            [Row] -> Parser [Row]
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Row] -> Parser [Row]) -> [Row] -> Parser [Row]
forall a b. (a -> b) -> a -> b
$ [Cell] -> Row
Row (CellFormat -> [TableTextTree] -> Width -> Width -> Cell
Cell CellFormat
schemaCellFormat [] Width
1 Width
1 Cell -> [Cell] -> [Cell]
forall a. a -> [a] -> [a]
: [Cell]
schemaCells) Row -> [Row] -> [Row]
forall a. a -> [a] -> [a]
: [Row]
categoryRows

        plainP :: Parser [Row]
        plainP :: Parser [Row]
plainP = do
            Row
schemaRow <- Parser Row
lexSchemaP
            [Row]
groups <- ([Cell] -> Row) -> [[Cell]] -> [Row]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Cell] -> Row
Row ([[Cell]] -> [Row])
-> ParsecT Void Text Identity [[Cell]] -> Parser [Row]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Cell] -> ParsecT Void Text Identity [[Cell]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser [Cell] -> Parser [Cell]
forall (m :: * -> *) a. MonadParser m => m a -> m a
nLexeme (Parser [Cell] -> Parser [Cell]) -> Parser [Cell] -> Parser [Cell]
forall a b. (a -> b) -> a -> b
$ ModuleType -> TextType Void -> Parser [Cell]
moduleP ModuleType
moduleType TextType Void
tt)
            [Row] -> Parser [Row]
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Row] -> Parser [Row]) -> [Row] -> Parser [Row]
forall a b. (a -> b) -> a -> b
$ Row
schemaRow Row -> [Row] -> [Row]
forall a. a -> [a] -> [a]
: [Row]
groups

        lexSchemaP :: Parser Row
lexSchemaP = Parser Row -> Parser Row
forall (m :: * -> *) a. MonadParser m => m a -> m a
lexeme (ModuleSchemaType -> TextType Void -> Parser Row
schemaP ModuleSchemaType
schemaType TextType Void
tt)