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