{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Read.Tree where
import Control.Applicative (Applicative(..), Alternative(..))
import Data.Functor ((<$>), ($>), (<$))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
-import Data.String (String)
+import Data.String (IsString(..))
import Data.Text (Text)
-import Prelude (undefined, Int, Num(..), toInteger)
+import Data.TreeSeq.Strict (Tree(..), Trees)
+import Prelude (undefined, Num(..))
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Text.Megaparsec as P
+import qualified Text.Megaparsec.Char as P
-import Language.TCT.Tree
+import Language.TCT.Cell
import Language.TCT.Token
+import Language.TCT.Tree
+import Language.TCT.Read.Cell
import Language.TCT.Read.Elem
-p_Position :: Parser e s (Line,Column)
-p_Position = (<$> P.getPosition) $ \p ->
- ( 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.skipMany $ P.char ' '
pos <- p_Position
key <- pdbg "Key" $
P.choice $
- [ P.try $ P.string "- " $> KeyDash
- -- TODO: KeyNum
- -- TODO: KeyComment
+ [ P.try $ P.char '-' >>
+ P.char ' ' $> KeyDash <|>
+ P.string "- " $> KeyDashDash
+ , 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==' '))
, P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
return $ KeySection $ List.length hs
+ , P.try $
+ KeyBrackets
+ <$> P.between (P.string "[") (P.string "]") p_Name
+ <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n')))
+ , P.try $
+ (\f -> KeyDotSlash $ "./"<>f)
+ <$ P.string "./"
+ <*> P.many (P.satisfy (/='\n'))
, do
- name <-
- Text.pack
- <$> many (P.satisfy $ \c ->
- Char.isAlphaNum c || c=='-' || c=='_')
+ name <- p_Name
wh <- Text.pack <$> P.many (P.char ' ')
P.choice
[ P.try $ KeyColon name wh
, P.char '>' $> KeyGreat name wh
, P.char '=' $> KeyEqual name wh
, P.char '|' $> KeyBar name wh
- -- TODO: KeyAt
]
]
posEnd <- p_Position
let row' = TreeN (Cell pos posEnd key) mempty : row
case key of
- KeySection{} -> p_CellEnd row'
- KeyDash{} -> 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'
+ KeySection{} -> p_CellEnd row'
+ KeyDash{} -> p_Row row'
+ KeyDashDash{} -> p_CellText row'
+ KeyDot{} -> p_Row row'
+ KeyColon{} -> p_Row row'
+ KeyBrackets{} -> p_Row row'
+ KeyGreat{} -> p_Row row'
+ KeyEqual{} -> p_CellEnd row'
+ KeyBar{} -> p_CellEnd row'
+ KeyDotSlash{} -> p_CellEnd row'
+ KeyLower{} -> undefined -- NOTE: handled in 'p_CellLower'
+
+p_Name :: Parser e s Name
+p_Name =
+ (\h t -> Text.pack (h:t))
+ <$> (P.satisfy $ \c ->
+ Char.isAlphaNum c || c=='_')
+ <*> many (P.satisfy $ \c ->
+ Char.isAlphaNum c || c=='-' || c=='_')
+
+p_Line :: Parser e s Text
+p_Line = Text.pack <$> P.many (P.satisfy (/='\n'))
-p_CellLower :: Row -> Parser e s Row
+p_CellLower :: forall e s. Row -> Parser e s Row
p_CellLower row = pdbg "CellLower" $ do
P.skipMany $ P.char ' '
pos <- p_Position
void $ P.char '<'
- name <- p_name
+ name <- p_Name
attrs <- p_attrs
posClose <- p_Position
let treeHere =
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) ' '
+ let indent = fromString $ List.replicate (columnPos pos - 1) ' '
tree <-
- P.try (P.char '>' >> treeElem (tokens [TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|>
+ P.try (P.char '>' >> treeElem (tokens [cell0 $ 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)
where
- p_name :: Parser e s Name
- p_name =
- Text.pack
- <$> many (P.satisfy $ \c ->
- Char.isAlphaNum c || c=='-' || c=='_')
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
+ content <- p_Line
posEnd <- p_Position
return $ Cell pos posEnd content
- p_CellLines :: String -> Parser e s (Cell Text)
+ p_CellLines :: P.Tokens s -> 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)
+ <$> 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 = P.dbg "CellLinesUntilElemEnd" $ do
+ p_CellLinesUntilElemEnd :: P.Tokens s -> Text -> Parser e s (Cell Text)
+ p_CellLinesUntilElemEnd indent name = do
pos <- p_Position
content <- Text.intercalate "\n" . List.reverse <$> go []
posEnd <- p_Position
where
go :: [Text] -> Parser e s [Text]
go ls =
- P.try ((\w p l -> Text.pack w <> Text.pack p <> l : ls)
+ P.try ((\w l -> Text.pack w <> "</" <> name <> l : ls)
<$> P.many (P.char ' ')
- <*> P.string ("</"<>Text.unpack name)
- <*> p_line) <|>
- (p_line >>= \l -> P.try $
+ <* P.string (fromString $ "</"<>Text.unpack name)
+ <*> p_Line) <|>
+ (p_Line >>= \l -> P.try $
P.char '\n' >>
P.string indent >>
go (l:ls))
p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
p_Trees = unRoot . collapseRows <$> p_Rows [root]
where
- root = TreeN (Cell (0,0) (0,0) KeyDash) mempty
- unRoot (TreeN (unCell -> KeyDash) roots) = roots
+ root = TreeN (cell0 KeyDashDash) mempty
+ unRoot (TreeN (unCell -> KeyDashDash) roots) = roots
unRoot _ = undefined
sourcephile / git / doclang.git / blobdiff