Fix CSS titles and pages.

[doclang.git] / Language / TCT / Read / Tree.hs

diff --git a/Language/TCT/Read/Tree.hs b/Language/TCT/Read/Tree.hs
index 712b247f06fd8113af2f6ff7649e718c127b2b96..f6ba041ac87741ead8624e299e762ad0cb88ca2c 100644 (file)
--- a/Language/TCT/Read/Tree.hs
+++ b/Language/TCT/Read/Tree.hs
@@ -2,9 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
 module Language.TCT.Read.Tree where
 
 import Control.Applicative (Applicative(..), Alternative(..))
@@ -13,10 +11,11 @@ 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.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
@@ -33,41 +32,40 @@ import Language.TCT.Read.Token
 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
-       header <- debugParser "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_CellRaw  row'
@@ -95,18 +93,17 @@ 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
-       pos      <- p_Position
-       void     $  P.char '<'
-       name     <- p_Name
-       attrs    <- p_ElemAttrs
-       posClose <- p_Position
+       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 = pairBordersDouble
                   | otherwise  = pairBordersSingle
@@ -114,7 +111,7 @@ p_CellLower row = debugParser "CellLower" $ do
                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 ""))
+               (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)
@@ -147,19 +144,19 @@ 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_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
+       return $ tree0 n : row
 
-p_CellSpaces1 :: Row -> Parser e s 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 = debugParser "CellEnd" $