Add --output option.
[doclang.git] / Language / TCT / Read / Tree.hs
index 17b4d688574429ad7913cf98393046c1928d8e71..f6ba041ac87741ead8624e299e762ad0cb88ca2c 100644 (file)
@@ -1,7 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 module Language.TCT.Read.Tree where
 
@@ -11,178 +11,171 @@ 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.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