{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Hdoc.TCT.Read.Tree where import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..), void) import Data.Bool import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor ((<$>), ($>), (<$)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.TreeSeq.Strict (Tree(..), Trees, tree0) import qualified Data.List as List import qualified Data.Sequence as Seq import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import Hdoc.TCT.Debug import Hdoc.TCT.Cell import Hdoc.TCT.Tree import Hdoc.TCT.Read.Cell import Hdoc.TCT.Read.Elem import Hdoc.TCT.Read.Token p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_CellHeader row = debugParser "CellHeader" $ do P.skipMany $ P.char ' ' Cell sp h <- p_Cell $ do debugParser "Header" $ P.choice [ P.try $ P.char '-' >> P.char ' ' $> HeaderDash <|> P.string "- " $> HeaderDashDash , P.try $ HeaderDot <$> p_Digits <* P.char '.' <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' ')) , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs -> return $ HeaderSection $ List.length hs , P.try $ HeaderBrackets <$> P.between (P.string "[") (P.string "]") p_Name <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n'))) , P.try $ (\f -> HeaderDotSlash $ "./"<>f) <$ P.string "./" <*> P.many (P.satisfy (/='\n')) , do name <- p_Name wh <- p_HSpaces P.choice [ P.try $ HeaderColon name wh <$ P.char ':' <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' ')) , P.char '>' $> HeaderGreat name wh , P.char '=' $> HeaderEqual name wh , P.char '|' $> HeaderBar name wh ] ] let row' = Tree (Cell sp $ NodeHeader h) mempty : row case h of HeaderSection{} -> p_CellEnd row' HeaderDash{} -> p_Row row' HeaderDashDash{} -> p_CellRaw row' HeaderDot{} -> p_Row row' HeaderColon{} -> p_Row row' HeaderBrackets{} -> p_Row row' HeaderGreat{} -> p_Row row' HeaderEqual{} -> p_CellRaw row' HeaderBar{} -> p_CellRaw row' HeaderDotSlash{} -> p_CellEnd row' p_Name :: P.Tokens s ~ TL.Text => Parser e s Name p_Name = p_AlphaNums {- (\h t -> Text.pack (h:t)) <$> (P.satisfy $ \c -> Char.isAlphaNum c || c=='_') <*> P.takeWhile1P (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_') -} p_Line :: P.Tokens s ~ TL.Text => Parser e s TL.Text p_Line = P.takeWhileP (Just "Line") (/='\n') p_Line1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text p_Line1 = P.takeWhile1P (Just "Line") (/='\n') p_CellLower :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_CellLower row = debugParser "CellLower" $ do indent <- p_HSpaces Cell ssp@(Span fp bp ep:|sp) (name,attrs) <- p_Cell $ do void $ P.char '<' (,) <$> p_Name <*> p_ElemAttrs let treeHere = Tree (Cell ssp $ NodeLower name attrs) . Seq.singleton . tree0 . (NodeText <$>) let treeElem hasContent nod (Cell (Span _fp _bp ep':|_sp) t) = let (o,_) = bs $ PairElem name attrs in tree0 $ Cell (Span fp bp ep':|sp) $ nod $ o<>t where bs | hasContent = pairBordersDouble | otherwise = pairBordersSingle cel <- P.try (P.char '>' >> treeElem True NodeText <$> p_CellLinesUntilElemEnd indent name) <|> P.try (P.char '\n' >> P.tokens (==) indent >> treeHere <$> p_CellLines indent) <|> P.try (P.tokens (==) "/>" >> treeElem False NodeText <$> p_CellLine) <|> (P.eof $> treeHere (Cell (Span fp ep ep:|sp) "")) return $ cel : row where p_CellLine :: P.Tokens s ~ TL.Text => Parser e s (Cell TL.Text) p_CellLine = p_Cell p_Line p_CellLines :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Parser e s (Cell TL.Text) p_CellLines indent = -- TODO: optimize special case indent == "" ? p_Cell $ TL.intercalate "\n" <$> P.sepBy (P.try p_Line) (P.try $ P.char '\n' >> P.tokens (==) indent) p_CellLinesUntilElemEnd :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Name -> Parser e s (Cell TL.Text) p_CellLinesUntilElemEnd indent name = p_Cell $ TL.intercalate "\n" . List.reverse <$> go [] -- TODO: optimize merging, and maybe case indent == "" where go :: P.Tokens s ~ TL.Text => [TL.Text] -> Parser e s [TL.Text] go ls = let end = " name in P.try ((\w l -> w <> end <> l : ls) <$> p_HSpaces <* P.tokens (==) end <*> p_Line) <|> (p_Line >>= \l -> P.try $ P.char '\n' >> P.tokens (==) indent >> go (l:ls)) p_CellText1 :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_CellText1 row = debugParser "CellText" $ do P.skipMany $ P.char ' ' n <- p_Cell $ NodeText <$> p_Line1 return $ tree0 n : row p_CellRaw :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_CellRaw row = debugParser "CellRaw" $ do P.skipMany $ P.char ' ' n <- p_Cell $ NodeText <$> p_Line return $ tree0 n : row p_CellSpaces1 :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_CellSpaces1 row = debugParser "CellSpaces" $ do P.skipSome $ P.char ' ' cell <- p_Cell $ NodeText <$> P.string "" return $ tree0 cell : row p_CellEnd :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_CellEnd row = debugParser "CellEnd" $ P.try (p_CellLower row) <|> P.try (p_CellText1 row) <|> p_CellSpaces1 row <|> return row p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row p_Row row = debugParser "Row" $ P.try (p_CellHeader row) <|> p_CellEnd row p_Rows :: P.Tokens s ~ TL.Text => Rows -> Parser e s Rows p_Rows rows = p_Row [] >>= \row -> let rows' = rows `mergeRow` row in (P.eof $> rows') <|> (P.newline >> {- USELESS: P.eof $> rows' <|>-} p_Rows rows') p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node)) p_Trees = collapseRows <$> p_Rows initRows