]> Git — Sourcephile - doclang.git/blob - Hdoc/TCT/Read/Tree.hs
DTC: add <page-ref> draft
[doclang.git] / Hdoc / TCT / Read / Tree.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE Rank2Types #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TypeFamilies #-}
6 module Hdoc.TCT.Read.Tree where
7
8 import Control.Applicative (Applicative(..), Alternative(..))
9 import Control.Monad (Monad(..), void)
10 import Data.Bool
11 import Data.Char (Char)
12 import Data.Eq (Eq(..))
13 import Data.Function (($), (.))
14 import Data.Functor ((<$>), ($>), (<$))
15 import Data.List.NonEmpty (NonEmpty(..))
16 import Data.Maybe (Maybe(..), maybe)
17 import Data.Monoid (Monoid(..))
18 import Data.Semigroup (Semigroup(..))
19 import Data.TreeSeq.Strict (Tree(..), Trees, tree0)
20 import qualified Data.Char as Char
21 import qualified Data.List as List
22 import qualified Data.Sequence as Seq
23 import qualified Data.Text.Lazy as TL
24 import qualified Language.Symantic.XML as XML
25 import qualified Text.Megaparsec as P
26 import qualified Text.Megaparsec.Char as P
27
28 import Hdoc.TCT.Debug
29 import Hdoc.TCT.Cell
30 import Hdoc.TCT.Elem
31 import Hdoc.TCT.Tree
32 import Hdoc.TCT.Read.Cell
33 import Hdoc.TCT.Read.Elem
34 import Hdoc.TCT.Read.Token
35
36 p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
37 p_CellHeader row = debugParser "CellHeader" $ do
38 P.skipMany $ P.char ' '
39 Sourced sp h <- p_Cell $ do
40 debugParser "Header" $
41 P.choice
42 [ P.try $ P.char '-' >>
43 P.char ' ' $> HeaderDash <|>
44 P.string "- " $> HeaderDashDash
45 , P.try $ HeaderDot
46 <$> p_Digits
47 <* P.char '.'
48 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
49 , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
50 return $ HeaderSection $ List.length hs
51 , P.try $
52 HeaderBrackets
53 <$> P.between (P.char '[') (P.string "]:")
54 (P.takeWhile1P (Just "Reference") isReferenceChar)
55 -- <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n')))
56 , P.try $
57 (\f -> HeaderDotSlash $ "./"<>f)
58 <$ P.string "./"
59 <*> P.many (P.satisfy (/='\n'))
60 , do
61 name <- P.optional p_ElemName
62 wh <- p_HSpaces
63 P.choice
64 [ P.try $ HeaderColon name wh
65 <$ P.char ':'
66 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
67 , P.char '>' $> HeaderGreat name wh
68 , maybe empty (\n -> P.char '=' $> HeaderEqual n wh) name
69 , P.char '|' $> HeaderBar name wh
70 ]
71 ]
72 let row' = Tree (Sourced sp $ NodeHeader h) mempty : row
73 case h of
74 HeaderSection{} -> p_CellEnd row'
75 HeaderDash{} -> p_Row row'
76 HeaderDashDash{} -> p_CellRaw row'
77 HeaderDot{} -> p_Row row'
78 HeaderColon{} -> p_Row row'
79 HeaderBrackets{} -> p_Row row'
80 HeaderGreat{} -> p_Row row'
81 HeaderEqual{} -> p_CellRaw row'
82 HeaderBar{} -> p_CellRaw row'
83 HeaderDotSlash{} -> p_CellEnd row'
84
85 isReferenceChar :: Char -> Bool
86 isReferenceChar c =
87 c /= '[' &&
88 c /= ']' &&
89 Char.isPrint c &&
90 not (Char.isSpace c)
91
92 p_Name :: P.Tokens s ~ TL.Text => Parser e s ElemName
93 p_Name = XML.NCName <$> p_AlphaNums
94 {-
95 (\h t -> Text.pack (h:t))
96 <$> (P.satisfy $ \c -> Char.isAlphaNum c || c=='_')
97 <*> P.takeWhile1P (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_')
98 -}
99
100 p_Line :: P.Tokens s ~ TL.Text => Parser e s TL.Text
101 p_Line = P.takeWhileP (Just "Line") (/='\n')
102
103 p_Line1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
104 p_Line1 = P.takeWhile1P (Just "Line") (/='\n')
105
106 p_CellLower :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
107 p_CellLower row = debugParser "CellLower" $ do
108 indent <- p_HSpaces
109 Sourced ssp@(FileRange fp bp ep:|sp) (name, attrs) <-
110 p_Cell $ do
111 void $ P.char '<'
112 (,) <$> p_ElemName <*> p_ElemAttrs
113 let treeHere =
114 Tree (Sourced ssp $ NodeLower name attrs) .
115 Seq.singleton . tree0 . (NodeText <$>)
116 let treeElem hasContent nod (Sourced (FileRange _fp _bp ep':|_sp) t) =
117 let (o,_) = bs $ PairElem name attrs in
118 tree0 $ Sourced (FileRange fp bp ep':|sp) $ nod $ o<>t
119 where
120 bs | hasContent = pairBordersDouble
121 | otherwise = pairBordersSingle
122 cel <-
123 P.try (P.char '>' >> treeElem True NodeText <$> p_CellLinesUntilElemEnd indent name) <|>
124 P.try (P.char '\n' >> P.tokens (==) indent >> treeHere <$> p_CellLines indent) <|>
125 P.try (P.tokens (==) "/>" >> treeElem False NodeText <$> p_CellLine) <|>
126 (P.eof $> treeHere (Sourced (FileRange fp ep ep:|sp) ""))
127 return $ cel : row
128 where
129 p_CellLine :: P.Tokens s ~ TL.Text => Parser e s (Cell TL.Text)
130 p_CellLine = p_Cell p_Line
131 p_CellLines :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Parser e s (Cell TL.Text)
132 p_CellLines indent =
133 -- TODO: optimize special case indent == "" ?
134 p_Cell $
135 TL.intercalate "\n"
136 <$> P.sepBy (P.try p_Line)
137 (P.try $ P.char '\n' >> P.tokens (==) indent)
138 p_CellLinesUntilElemEnd :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> ElemName -> Parser e s (Cell TL.Text)
139 p_CellLinesUntilElemEnd indent (XML.NCName name) =
140 p_Cell $ TL.intercalate "\n" . List.reverse <$> go []
141 -- TODO: optimize merging, and maybe case indent == ""
142 where
143 go :: P.Tokens s ~ TL.Text => [TL.Text] -> Parser e s [TL.Text]
144 go ls =
145 let end = "</" <> name in
146 P.try ((\w l -> w <> end <> l : ls)
147 <$> p_HSpaces
148 <* P.tokens (==) end
149 <*> p_Line) <|>
150 (p_Line >>= \l -> P.try $
151 P.char '\n'
152 >> P.tokens (==) indent
153 >> go (l:ls))
154
155 p_CellText1 :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
156 p_CellText1 row = debugParser "CellText" $ do
157 P.skipMany $ P.char ' '
158 n <- p_Cell $ NodeText <$> p_Line1
159 return $ tree0 n : row
160
161 p_CellRaw :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
162 p_CellRaw row = debugParser "CellRaw" $ do
163 P.skipMany $ P.char ' '
164 n <- p_Cell $ NodeText <$> p_Line
165 return $ tree0 n : row
166
167 p_CellSpaces1 :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
168 p_CellSpaces1 row = debugParser "CellSpaces" $ do
169 P.skipSome $ P.char ' '
170 cell <- p_Cell $ NodeText <$> P.string ""
171 return $ tree0 cell : row
172
173 p_CellEnd :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
174 p_CellEnd row = debugParser "CellEnd" $
175 P.try (p_CellLower row) <|>
176 P.try (p_CellText1 row) <|>
177 p_CellSpaces1 row <|>
178 return row
179
180 p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
181 p_Row row = debugParser "Row" $
182 P.try (p_CellHeader row) <|>
183 p_CellEnd row
184
185 p_Rows :: P.Tokens s ~ TL.Text => Rows -> Parser e s Rows
186 p_Rows rows =
187 p_Row [] >>= \row ->
188 let rows' = rows `mergeRow` row in
189 (P.eof $> rows') <|>
190 (P.newline >> {- USELESS: P.eof $> rows' <|>-} p_Rows rows')
191
192 p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node))
193 p_Trees = collapseRows <$> p_Rows initRows