{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Read.Tree where
--- import Data.String (IsString(..))
--- import qualified Data.TreeSeq.Strict as TreeSeq
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.Foldable (toList)
+import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
-import Data.TreeSeq.Strict (Tree(..), Trees)
+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 Language.TCT.Debug
import Language.TCT.Cell
--- import Language.TCT.Token
import Language.TCT.Tree
import Language.TCT.Read.Cell
import Language.TCT.Read.Elem
import Language.TCT.Read.Token
p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
-p_CellHeader row = pdbg "CellHeader" $ do
+p_CellHeader row = debugParser "CellHeader" $ do
P.skipMany $ P.char ' '
- pos <- p_Position
- header <- pdbg "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
+ Cell sp h <- p_Cell $ do
+ debugParser "Header" $
P.choice
- [ P.try $ HeaderColon name wh
- <$ P.char ':'
+ [ 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.char '>' $> HeaderGreat name wh
- , P.char '=' $> HeaderEqual name wh
- , P.char '|' $> HeaderBar name wh
+ , 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
+ ]
]
- ]
- posEnd <- p_Position
- let row' = Tree (Cell pos posEnd $ NodeHeader header) mempty : row
- case header of
+ let row' = Tree (Cell sp $ NodeHeader h) mempty : row
+ case h of
HeaderSection{} -> p_CellEnd row'
HeaderDash{} -> p_Row row'
- HeaderDashDash{} -> p_CellText row'
+ HeaderDashDash{} -> p_CellRaw row'
HeaderDot{} -> p_Row row'
HeaderColon{} -> p_Row row'
HeaderBrackets{} -> p_Row row'
HeaderGreat{} -> p_Row row'
- HeaderEqual{} -> p_CellEnd row'
- HeaderBar{} -> p_CellEnd row'
+ HeaderEqual{} -> p_CellRaw row'
+ HeaderBar{} -> p_CellRaw row'
HeaderDotSlash{} -> p_CellEnd row'
- -- HeaderLower{} -> undefined -- NOTE: handled in 'p_CellLower'
- -- TODO: move to a NodeLower
- -- HeaderPara -> undefined -- NOTE: only introduced later in 'appendRow'
p_Name :: P.Tokens s ~ TL.Text => Parser e s Name
p_Name = p_AlphaNums
p_Line1 = P.takeWhile1P (Just "Line") (/='\n')
p_CellLower :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
-p_CellLower row = pdbg "CellLower" $ do
- indent <- p_HSpaces
- pos <- p_Position
- void $ P.char '<'
- name <- p_Name
- attrs <- p_ElemAttrs
- posClose <- p_Position
+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 pos posClose $ NodeLower name attrs) .
- Seq.singleton . Tree0 . (NodeText <$>)
- let treeElem hasContent nod (Cell _ p t) =
+ 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 pos p $ nod $ o<>t
+ tree0 $ Cell (Span fp bp ep':|sp) $ nod $ o<>t
where
- bs | hasContent = pairBorders
- | otherwise = pairBordersWithoutContent
- tree <-
+ 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 posClose posClose ""))
- return $ tree : row
+ (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.tokens (==) indent
>> go (l:ls))
-p_CellText :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
-p_CellText row = pdbg "CellText" $ do
+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
+ return $ tree0 n : row
-p_CellSpaces :: Row -> Parser e s Row
-p_CellSpaces row = pdbg "CellSpaces" $ do
+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 ' '
- pos <- p_Position
- return $ Tree0 (Cell pos pos $ NodeText "") : row
+ 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 = pdbg "CellEnd" $
+p_CellEnd row = debugParser "CellEnd" $
P.try (p_CellLower row) <|>
- P.try (p_CellText row) <|>
- p_CellSpaces 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 = pdbg "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' = appendRow rows (List.reverse row) in
+ let rows' = rows `mergeRow` row in
(P.eof $> rows') <|>
- (P.newline >> P.eof $> rows' <|> p_Rows 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 = unNodePara . subTrees . collapseRows <$> p_Rows [root]
- where
- root = Tree (cell0 $ NodeHeader HeaderDashDash) mempty
- unNodePara :: Trees (Cell Node) -> Trees (Cell Node)
- unNodePara (toList -> [(Tree (unCell -> NodePara) ts)]) = ts
- unNodePara ts = ts
+p_Trees = collapseRows <$> p_Rows initRows
sourcephile / git / doclang.git / blobdiff