Study StateMarkup.
[doclang.git] / Language / TCT / Read / Tree.hs
index b47bba49af34b9a40a4e63d79c377cde03e41386..9536edd3b43ced6ab3fe1d32f8398e819715fee6 100644 (file)
@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 module Language.TCT.Read.Tree where
@@ -13,48 +14,48 @@ import Data.Function (($), (.))
 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
@@ -63,61 +64,91 @@ p_CellKey row = pdbg "CellKey" $ do
                         , 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_CellLower :: Row -> Parser e s Row
+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 :: 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 <-
-               Text.pack
-                <$> many (P.satisfy $ \c ->
-                       Char.isAlphaNum c || c=='-' || c=='_')
-       attrs <- P.many $ P.try $ (,) <$> (Text.pack <$> P.some (P.char ' ')) <*> p_Attr
+       name <- p_Name
+       attrs <- p_attrs
        posClose <- p_Position
        let treeHere =
                TreeN (Cell pos posClose $ KeyLower name attrs) .
                Seq.singleton . Tree0
-       let treeElem m (Cell _ p c) =
-               let (o,_) = pairBorders (PairElem name attrs) m in
+       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 mempty <$> p_lines indent) <|>
-               P.try (P.char '\n' >> P.string indent >> treeHere <$> p_lines indent) <|>
-               P.try (P.string "/>" >> treeElem (Tokens mempty) <$> p_line) <|>
+               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_line :: Parser e s (Cell Text)
-       p_line = do
-               pos <- p_Position
-               content <- Text.pack <$> P.many (P.satisfy (/='\n'))
-               posEnd <- p_Position
+       p_attrs = P.many $ P.try $
+               (,)
+                <$> (Text.pack <$> P.some (P.char ' '))
+                <*> p_Attr
+       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_lines :: String -> Parser e s (Cell Text)
-       p_lines indent = do
+       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 $ Text.pack <$> P.many (P.satisfy (/='\n')))
-                                (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 :: 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
+               return $ Cell pos posEnd content
+               where
+               go :: [Text] -> Parser e s [Text]
+               go ls =
+                       P.try ((\w l -> Text.pack w <> "</" <> name <> l : ls)
+                        <$> P.many (P.char ' ')
+                        <*  P.string (fromString $ "</"<>Text.unpack name)
+                        <*> p_Line) <|>
+                       (p_Line >>= \l -> P.try $
+                               P.char '\n' >>
+                               P.string indent >>
+                               go (l:ls))
 
 p_CellText :: Row -> Parser e s Row
 p_CellText row = pdbg "CellText" $ do
@@ -155,6 +186,6 @@ p_Rows rows =
 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