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