{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Language.TCT.Read.Tree where
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.String (String)
-import Data.Text (Text)
-import Prelude (undefined, Int, Num(..), toInteger)
-import qualified Data.Char as Char
+import Data.TreeSeq.Strict (Tree(..), Trees, tree0)
import qualified Data.List as List
import qualified Data.Sequence as Seq
-import qualified Data.Text as Text
+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.Tree
-import Language.TCT.Token
+import Language.TCT.Read.Cell
import Language.TCT.Read.Elem
+import Language.TCT.Read.Token
-p_Position :: Parser e s Pos
-p_Position = (<$> P.getPosition) $ \p ->
- Pos
- (intOfPos $ P.sourceLine p)
- (intOfPos $ P.sourceColumn p)
-intOfPos :: P.Pos -> Int
-intOfPos = fromInteger . toInteger . P.unPos
-
-p_Line :: Parser e s Line
-p_Line = intOfPos . P.sourceLine <$> P.getPosition
-
-p_Column :: Parser e s Column
-p_Column = intOfPos . P.sourceColumn <$> P.getPosition
-
-p_CellKey :: Row -> Parser e s Row
-p_CellKey row = pdbg "CellKey" $ do
+p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
+p_CellHeader row = debugParser "CellHeader" $ do
P.skipMany $ P.char ' '
- pos <- p_Position
- key <- pdbg "Key" $
- P.choice $
- [ P.try $ P.string "- " $> KeyDash
- , P.try $ KeyDot . Text.pack
- <$> P.some (P.satisfy Char.isDigit)
- <* P.char '.'
- <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
- -- TODO: KeyComment
- , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
- return $ KeySection $ List.length hs
- , do
- name <- p_Name
- wh <- Text.pack <$> P.many (P.char ' ')
+ Cell sp h <- p_Cell $ do
+ debugParser "Header" $
P.choice
- [ P.try $ KeyColon 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 '>' $> KeyGreat name wh
- , P.char '=' $> KeyEqual name wh
- , P.char '|' $> KeyBar name wh
- -- TODO: KeyAt
+ , 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' = TreeN (Cell pos posEnd key) mempty : row
- case key of
- KeySection{} -> p_CellEnd row'
- KeyDash{} -> p_Row row'
- KeyDot{} -> p_Row row'
- KeyColon{} -> p_Row row'
- KeyGreat{} -> p_Row row'
- KeyEqual{} -> p_CellEnd row'
- KeyBar{} -> p_CellEnd row'
- KeyLower{} -> undefined -- NOTE: handled in 'p_CellLower'
+ 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 :: Parser e s Name
-p_Name =
+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=='_')
- <*> many (P.satisfy $ \c ->
- Char.isAlphaNum c || c=='-' || c=='_')
+ <$> (P.satisfy $ \c -> Char.isAlphaNum c || c=='_')
+ <*> P.takeWhile1P (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_')
+ -}
-p_CellLower :: Row -> Parser e s Row
-p_CellLower row = pdbg "CellLower" $ do
- P.skipMany $ P.char ' '
- pos <- p_Position
- void $ P.char '<'
- name <- p_Name
- attrs <- p_attrs
- posClose <- p_Position
+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 =
- TreeN (Cell pos posClose $ KeyLower name attrs) .
- Seq.singleton . Tree0
- let treeElem toks (Cell _ p c) =
- let (o,_) = pairBorders (PairElem name attrs) toks in
- Tree0 $ Cell pos p (o<>c)
- let indent = List.replicate (columnPos pos - 1) ' '
- tree <-
- P.try (P.char '>' >> treeElem (tokens [TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|>
- P.try (P.char '\n' >> P.string indent >> treeHere <$> p_CellLines indent) <|>
- P.try (P.string "/>" >> treeElem mempty <$> p_CellLine) <|>
- (P.eof $> treeHere (Cell posClose posClose ""))
- return (tree:row)
+ 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_attrs = P.many $ P.try $
- (,)
- <$> (Text.pack <$> P.some (P.char ' '))
- <*> p_Attr
- p_line :: Parser e s Text
- p_line = Text.pack <$> P.many (P.satisfy (/='\n'))
- p_CellLine :: Parser e s (Cell Text)
- p_CellLine = do
- pos <- p_Position
- content <- p_line
- posEnd <- p_Position
- return $ Cell pos posEnd content
- p_CellLines :: String -> Parser e s (Cell Text)
- p_CellLines indent = do
- pos <- p_Position
- content <-
- Text.intercalate "\n"
- <$> P.sepBy (P.try p_line) (P.try $ P.char '\n' >> P.string indent)
- posEnd <- p_Position
- return $ Cell pos posEnd content
- p_CellLinesUntilElemEnd :: String -> Text -> Parser e s (Cell Text)
- p_CellLinesUntilElemEnd indent name = do
- pos <- p_Position
- content <- Text.intercalate "\n" . List.reverse <$> go []
- posEnd <- p_Position
- return $ Cell pos posEnd content
+ 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 :: [Text] -> Parser e s [Text]
+ go :: P.Tokens s ~ TL.Text => [TL.Text] -> Parser e s [TL.Text]
go ls =
- P.try ((\w p l -> Text.pack w <> Text.pack p <> l : ls)
- <$> P.many (P.char ' ')
- <*> P.string ("</"<>Text.unpack name)
- <*> p_line) <|>
- (p_line >>= \l -> P.try $
- P.char '\n' >>
- P.string indent >>
- go (l: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_CellText :: 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 ' '
- pos <- p_Position
- line <- Text.pack <$> P.some (P.satisfy (/='\n'))
- posEnd <- p_Position
- return $ Tree0 (Cell pos posEnd line) : row
+ n <- p_Cell $ NodeText <$> p_Line1
+ 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 "") : row
+ cell <- p_Cell $ NodeText <$> P.string ""
+ return $ tree0 cell : row
-p_CellEnd :: Row -> Parser e s Row
-p_CellEnd row = pdbg "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_CellText row) <|>
- p_CellSpaces row <|>
+ P.try (p_CellText1 row) <|>
+ p_CellSpaces1 row <|>
return row
-p_Row :: Row -> Parser e s Row
-p_Row row = pdbg "Row" $
- P.try (p_CellKey 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 :: Rows -> Parser e s Rows
+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_Rows rows')
+ (P.newline >> {- USELESS: P.eof $> rows' <|>-} p_Rows rows')
-p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
-p_Trees = unRoot . collapseRows <$> p_Rows [root]
- where
- root = TreeN (Cell pos0 pos0 KeyDash) mempty
- unRoot (TreeN (unCell -> KeyDash) roots) = roots
- unRoot _ = undefined
+p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node))
+p_Trees = collapseRows <$> p_Rows initRows