]> Git — Sourcephile - doclang.git/blob - Hdoc/TCT/Read/Token.hs
Fix TCT Reference ID syntax.
[doclang.git] / Hdoc / TCT / Read / Token.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE Rank2Types #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# OPTIONS_GHC -fno-warn-orphans #-}
8 module Hdoc.TCT.Read.Token where
9
10 import Control.Applicative (Applicative(..), Alternative(..))
11 import Control.Monad (Monad(..))
12 import Data.Bool
13 import Data.Char (Char)
14 import Data.Either (Either(..))
15 import Data.Eq (Eq(..))
16 import Data.Foldable (Foldable(..))
17 import Data.Function (($), (.))
18 import Data.Functor ((<$>), ($>))
19 import Data.List.NonEmpty (NonEmpty(..))
20 import Data.Maybe (Maybe(..))
21 import Data.Monoid (Monoid(..))
22 import Data.Semigroup (Semigroup(..))
23 import Data.Sequence (ViewL(..), ViewR(..), (<|))
24 import Data.TreeSeq.Strict (Tree(..), Trees)
25 import Data.Tuple (fst,snd)
26 import Data.Void (Void)
27 import Prelude (Num(..))
28 import Text.Show (Show(..))
29 import qualified Data.Char as Char
30 import qualified Data.List.NonEmpty as NonEmpty
31 import qualified Data.Sequence as Seq
32 import qualified Data.Text as Text
33 import qualified Data.Text.Lazy as TL
34 import qualified Text.Megaparsec as P
35 import qualified Text.Megaparsec.Char as P
36
37 import Hdoc.TCT.Debug
38 import Hdoc.TCT.Cell
39 import Hdoc.TCT.Elem
40 import Hdoc.TCT.Tree
41 import Hdoc.TCT.Read.Elem
42 import Hdoc.TCT.Read.Cell
43
44 -- * Type 'Pairs'
45 -- | Right-only Dyck language,
46 -- to keep track of opened 'Pair's.
47 type Pairs = (Tokens,[Opening])
48 type Tokens = Trees (Cell Node)
49
50 -- ** Type 'Opening'
51 -- | An opened 'Pair' and its content so far.
52 type Opening = (Cell Pair,Tokens)
53
54 appendPairsToken :: Pairs -> Tree (Cell Node) -> Pairs
55 appendPairsToken ps t = appendPairsTokens ps (pure t)
56
57 appendPairsText :: Pairs -> Cell TL.Text -> Pairs
58 appendPairsText ps (Cell sp t) =
59 appendPairsToken ps $
60 Tree0 $ Cell sp $
61 NodeToken $ TokenText t
62
63 appendPairsTokens :: Pairs -> Tokens -> Pairs
64 appendPairsTokens (ts,[]) toks = (ts`unionTokens`toks,[])
65 appendPairsTokens (ts,(p0,t0):ps) toks = (ts,(p0,t0`unionTokens`toks):ps)
66
67 -- | Unify two 'Tokens', merging border 'TokenText's if any.
68 unionTokens :: Tokens -> Tokens -> Tokens
69 unionTokens x y =
70 case (Seq.viewr x, Seq.viewl y) of
71 (xs :> x0, y0 :< ys) ->
72 case (x0,y0) of
73 ( Tree (Cell (Span fx bx _ex:| lx) (NodeToken (TokenText tx))) tsx
74 , Tree (Cell (Span _fy _by ey:|_ly) (NodeToken (TokenText ty))) tsy ) ->
75 xs `unionTokens`
76 pure (Tree (Cell (Span fx bx ey:|lx) $ NodeToken $ TokenText $ tx <> ty) (tsx<>tsy)) `unionTokens`
77 ys
78 _ -> x <> y
79 (EmptyR, _) -> y
80 (_, EmptyL) -> x
81
82 unionsTokens :: Foldable f => f Tokens -> Tokens
83 unionsTokens = foldl' unionTokens mempty
84
85 openPair :: Pairs -> Cell Pair -> Pairs
86 openPair (t,ps) p = (t,(p,mempty):ps)
87
88 -- | Close a 'Pair' when there is a matching 'LexemePairClose'.
89 closePair :: Pairs -> Cell Pair -> Pairs
90 closePair ps@(_,[]) (Cell loc p) = -- debug0 "closePair" $
91 appendPairsText ps $ Cell loc $
92 snd $ pairBordersDouble p
93 closePair (t,(cx@(Cell (Span fx bx _ex:| lx) px),t1):ts)
94 cy@(Cell (Span _fy _by ey:|_ly) py) = -- debug0 "closePair" $
95 case (px,py) of
96 (PairElem nx ax, PairElem ny ay) | nx == ny ->
97 appendPairsToken (t,ts) $
98 Tree (Cell (Span fx bx ey:|lx) $ NodePair $ PairElem nx as) t1
99 where as | null ay = ax
100 | otherwise = ax<>ay
101 _ | px == py ->
102 appendPairsToken (t,ts) $
103 Tree (Cell (Span fx bx ey:|lx) $ NodePair px) t1
104 _ ->
105 (`closePair` cy) $
106 appendPairsTokens
107 (t,ts)
108 (closeImpaired mempty (cx,t1))
109
110 -- | Close a 'Pair' when there is no matching 'LexemePairClose'.
111 closeImpaired :: Tokens -> (Cell Pair, Tokens) -> Tokens
112 closeImpaired acc (Cell loc@(s0:|lp) pair, toks) = -- debug0 "closeImpaired" $
113 case pair of
114 -- NOTE: try to close 'PairHash' as 'TokenTag' instead of 'TokenPlain'.
115 PairHash | Just (Cell (Span{span_end}:|_lt) tag, rest) <- tagFrom body ->
116 Tree0 (Cell (s0{span_end}:|lp) $ NodeToken $ TokenTag tag) <| rest
117 -- NOTE: use bp (not bt) to include the '#'
118 _ -> pure open `unionTokens` body
119 where
120 body = toks `unionTokens` acc
121 open = Tree0 $ Cell loc $ NodeToken $ TokenText $ fst $ pairBordersDouble pair
122
123 -- | Close remaining 'Pair's at end of parsing.
124 closePairs :: Pairs -> Tokens
125 closePairs (t0,ps) = -- debug0 "closePairs" $
126 t0 `unionTokens` foldl' closeImpaired mempty ps
127
128 appendLexeme :: Lexeme -> Pairs -> Pairs
129 appendLexeme lex acc = -- debug2 "appendLexeme" "lex" "acc" $ \lex acc ->
130 case lex of
131 LexemePairOpen ps -> foldl' open acc ps
132 where
133 -- NOTE: insert an empty node to encode <elem></elem>, not <elem/>
134 open a p@(Cell (Span{span_end, ..}:|sp) PairElem{}) = openPair a p `appendPairsText` Cell (Span{span_begin=span_end, ..}:|sp) ""
135 open a p = openPair a p
136 LexemePairClose ps -> foldl' closePair acc ps
137 LexemePairAny ps -> foldl' openPair acc ps
138 {-
139 LexemePairAny ps ->
140 appendPairsText acc $ sconcat $
141 ((fst . pairBordersSingle) <$>) <$> ps
142 -}
143 LexemePairBoth ps -> appendPairsTokens acc $ Seq.fromList $ toList $ Tree0 . (NodePair <$>) <$> ps
144 LexemeEscape c -> appendPairsToken acc $ Tree0 $ NodeToken . TokenEscape <$> c
145 LexemeLink t -> appendPairsToken acc $ Tree0 $ NodeToken . TokenLink <$> t
146 {-LexemeWhite (unCell -> "") -> acc-}
147 -- LexemeWhite (unCell -> Text.all (==' ') -> True) -> acc
148 LexemeWhite t -> appendPairsText acc t
149 LexemeAlphaNum t -> appendPairsText acc t
150 LexemeOther t -> appendPairsText acc t
151 LexemeTree t -> appendPairsToken acc t
152 LexemeEnd -> acc
153
154 appendLexemes :: Pairs -> [Lexeme] -> Pairs
155 appendLexemes = foldr appendLexeme
156
157 -- * Type 'Lexeme'
158 -- | 'Lexeme's cut the input in the longest chunks of common semantic,
159 -- this enables 'orientLexemePairAny' to work with a more meaningful context.
160 data Lexeme
161 = LexemePairOpen !(NonEmpty (Cell Pair))
162 | LexemePairClose !(NonEmpty (Cell Pair))
163 | LexemePairAny !(NonEmpty (Cell Pair))
164 -- ^ orientation depending on the surrounding 'Lexeme's,
165 -- see 'orientLexemePairAny'
166 | LexemePairBoth !(NonEmpty (Cell Pair))
167 | LexemeEscape !(Cell Char)
168 | LexemeLink !(Cell TL.Text)
169 | LexemeWhite !(Cell TL.Text)
170 | LexemeAlphaNum !(Cell TL.Text)
171 | LexemeOther !(Cell TL.Text)
172 | LexemeTree !(Tree (Cell Node))
173 | LexemeEnd
174 deriving (Eq, Show)
175 instance Pretty Lexeme
176
177 parseTokens :: [Lexeme] -> Tokens
178 parseTokens ps =
179 closePairs $
180 appendLexemes mempty $
181 -- debug0 "Lexemes (post orient)" $
182 orientLexemePairAny $ LexemeEnd :
183 ps
184
185 parseLexemes ::
186 Cell TL.Text ->
187 Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) [Lexeme]
188 parseLexemes = runParserOnCell (p_Lexemes <* P.eof)
189
190 -- | Parse 'Lexeme's, returning them in reverse order
191 -- to apply 'orientLexemePairAny'.
192 p_Lexemes :: P.Tokens s ~ TL.Text => Parser e s [Lexeme]
193 p_Lexemes = debugParser "Lexemes" $ go []
194 where
195 go :: P.Tokens s ~ TL.Text => [Lexeme] -> Parser e s [Lexeme]
196 go acc =
197 (P.eof $> acc) <|>
198 (p_Lexeme >>= \next -> go $ orientLexemePairAny $ next:acc)
199
200 -- | Must be called on parsed 'Lexeme's after the prepending of any new 'Lexeme',
201 -- so that it can try to orient nearby 'LexemePairAny'
202 -- to 'LexemePairOpen' or 'LexemePairClose'.
203 orientLexemePairAny :: [Lexeme] -> [Lexeme]
204 orientLexemePairAny = \case
205 -- LexemeOther (Cell _bx ex x):LexemeOther (Cell by _ey y):acc -> LexemeOther (Cell by ex (x<>y)):acc
206
207 -- "   
208 t@LexemeTree{}:LexemePairAny p:acc -> t:LexemePairClose p:acc
209 w@LexemeWhite{}:LexemePairAny p:acc -> w:LexemePairClose p:acc
210 LexemeEnd:LexemePairAny p:acc -> LexemePairClose p:acc
211 --    "
212 LexemePairAny p:t@LexemeTree{}:acc -> LexemePairOpen p:t:acc
213 LexemePairAny p:w@LexemeWhite{}:acc -> LexemePairOpen p:w:acc
214 LexemePairAny p:[] -> LexemePairOpen p:[]
215
216 --    ,,,"
217 LexemePairAny p:a@LexemeOther{}:w@LexemeWhite{}:acc -> LexemePairOpen p:a:w:acc
218 LexemePairAny p:a@LexemeOther{}:[] -> LexemePairOpen p:a:[]
219 -- ",,,   
220 w@LexemeWhite{}:a@LexemeOther{}:LexemePairAny p:acc -> w:a:LexemePairClose p:acc
221 LexemeEnd:a@LexemeOther{}:LexemePairAny p:acc -> a:LexemePairClose p:acc
222
223 -- ",,,AAA
224 an@LexemeAlphaNum{}:a@LexemeOther{}:LexemePairAny p:acc -> an:a:LexemePairClose p:acc
225 -- ,,,"AAA
226 an@LexemeAlphaNum{}:LexemePairAny p:a@LexemeOther{}:acc -> an:LexemePairOpen p:a:acc
227
228 -- ")
229 c@LexemePairClose{}:LexemePairAny p:acc -> c:LexemePairClose p:acc
230 -- ("
231 LexemePairAny p:o@LexemePairOpen{}:acc -> LexemePairOpen p:o:acc
232
233 -- "(
234 o@LexemePairOpen{}:LexemePairAny p:acc -> o:LexemePairClose p:acc
235 -- )"
236 LexemePairAny p:c@LexemePairClose{}:acc -> LexemePairClose p:c:acc
237
238 acc -> acc
239
240 p_Lexeme :: P.Tokens s ~ TL.Text => Parser e s Lexeme
241 p_Lexeme = debugParser "Lexeme" $
242 P.choice
243 [ P.try $ LexemeWhite <$> p_Cell p_Spaces1
244 , P.try $ LexemePairAny <$> p_some (p_Cell $ p_satisfyMaybe pairAny)
245 , P.try $ LexemePairBoth <$> p_some (P.try $ p_Cell p_ElemSingle)
246 , P.try $ LexemePairOpen <$> p_some (p_Cell $ p_satisfyMaybe pairOpen <|> P.try p_ElemOpen)
247 , P.try $ LexemePairClose <$> p_some (p_Cell $ p_satisfyMaybe pairClose <|> P.try p_ElemClose)
248 , P.try $ LexemeEscape <$> p_Cell p_Escape
249 , P.try $ LexemeLink <$> p_Cell p_Link
250 , P.try $ LexemeAlphaNum <$> p_Cell (P.takeWhile1P (Just "AlphaNum") Char.isAlphaNum)
251 , LexemeOther <$> p_Cell (TL.singleton <$> P.anyChar)
252 ]
253
254 p_some :: Parser e s a -> Parser e s (NonEmpty a)
255 p_some p = NonEmpty.fromList <$> P.some p
256
257 pairAny :: Char -> Maybe Pair
258 pairAny = \case
259 '-' -> Just PairDash
260 '/' -> Just PairSlash
261 '"' -> Just PairDoublequote
262 '\'' -> Just PairSinglequote
263 '`' -> Just PairBackquote
264 '_' -> Just PairUnderscore
265 '*' -> Just PairStar
266 '#' -> Just PairHash
267 _ -> Nothing
268
269 pairOpen :: Char -> Maybe Pair
270 pairOpen = \case
271 '(' -> Just PairParen
272 '[' -> Just PairBracket
273 '{' -> Just PairBrace
274 '«' -> Just PairFrenchquote
275 _ -> Nothing
276
277 pairClose :: Char -> Maybe Pair
278 pairClose = \case
279 ')' -> Just PairParen
280 ']' -> Just PairBracket
281 '}' -> Just PairBrace
282 '»' -> Just PairFrenchquote
283 _ -> Nothing
284
285 p_Escape :: Parser e s Char
286 p_Escape = P.char '\\' *> P.satisfy Char.isPrint
287
288 p_Link :: P.Tokens s ~ TL.Text => Parser e s TL.Text
289 p_Link =
290 P.try (P.char '<' *> p <* P.char '>') <|>
291 p
292 where
293 p :: P.Tokens s ~ TL.Text => Parser e s TL.Text
294 p =
295 (\scheme addr -> scheme <> "//" <> addr)
296 <$> P.option "" (P.try p_scheme)
297 <* P.string "//"
298 <*> p_addr
299 p_scheme :: P.Tokens s ~ TL.Text => Parser e s TL.Text
300 p_scheme =
301 (<> ":")
302 <$> (P.takeWhile1P (Just "scheme") $ \c ->
303 Char.isAlphaNum c
304 || c=='_'
305 || c=='-'
306 || c=='+')
307 <* P.char ':'
308 p_addr :: P.Tokens s ~ TL.Text => Parser e s TL.Text
309 p_addr =
310 P.takeWhileP (Just "addr") $ \c ->
311 Char.isAlphaNum c
312 || c=='%'
313 || c=='/'
314 || c=='('
315 || c==')'
316 || c=='-'
317 || c=='_'
318 || c=='.'
319 || c=='#'
320 || c=='?'
321 || c=='='
322 || c=='@'
323
324 pairBorders :: Foldable f => Pair -> f a -> (TL.Text,TL.Text)
325 pairBorders p ts | null ts = pairBordersSingle p
326 | otherwise = pairBordersDouble p
327
328 pairBordersSingle :: Pair -> (TL.Text,TL.Text)
329 pairBordersSingle = \case
330 PairElem n as ->
331 ("<"<>n<>foldMap f as<>"/>","")
332 where f (elemAttr_white,ElemAttr{..}) =
333 elemAttr_white <>
334 elemAttr_name <>
335 elemAttr_open <>
336 elemAttr_value <>
337 elemAttr_close
338 p -> pairBordersDouble p
339
340 pairBordersDouble :: Pair -> (TL.Text,TL.Text)
341 pairBordersDouble = \case
342 PairElem n as -> ("<"<>n<>foldMap f as<>">","</"<>n<>">")
343 where f (elemAttr_white,ElemAttr{..}) =
344 elemAttr_white <>
345 elemAttr_name <>
346 elemAttr_open <>
347 elemAttr_value <>
348 elemAttr_close
349 PairHash -> ("#","#")
350 PairStar -> ("*","*")
351 PairSlash -> ("/","/")
352 PairUnderscore -> ("_","_")
353 PairDash -> ("-","-")
354 PairBackquote -> ("`","`")
355 PairSinglequote -> ("'","'")
356 PairDoublequote -> ("\"","\"")
357 PairFrenchquote -> ("«","»")
358 PairParen -> ("(",")")
359 PairBrace -> ("{","}")
360 PairBracket -> ("[","]")
361
362 -- * Class 'TagFrom'
363 class TagFrom a where
364 tagFrom :: a -> Maybe (Cell Tag, a)
365 instance TagFrom Tokens where
366 tagFrom ts =
367 case Seq.viewl ts of
368 EmptyL -> Nothing
369 Tree0 (Cell loc0@(Span _f0 _b0 e0:|_l0) n) :< ns ->
370 case n of
371 NodeToken (TokenText t) ->
372 case tagFrom $ Cell loc0 t of
373 Nothing -> Nothing
374 Just (t0,r0) ->
375 if TL.null $ unCell r0
376 then
377 case tagFrom ns of
378 Just (t1@(Cell (Span _f1 b1 _e1:|_l1) _), r1) | e0 == b1 ->
379 Just (t0<>t1, r1)
380 _ -> Just (t0, ns)
381 else Just (t0, pure n0 `unionTokens` ns)
382 where n0 = Tree0 $ NodeToken . TokenText <$> r0
383 _ -> Nothing
384 _ -> Nothing
385 instance TagFrom (Cell TL.Text) where
386 tagFrom (Cell (Span fp bp ep:|sp) t)
387 | (w,r) <- TL.span isTagChar t
388 , not $ TL.null w
389 , ew <- pos_column bp + sum (Text.length <$> TL.toChunks w) =
390 Just
391 ( Cell (Span fp bp bp{pos_column=ew}:|sp) w
392 , Cell (Span fp bp{pos_column=ew} ep:|sp) r )
393 tagFrom _ = Nothing
394
395 isTagChar :: Char -> Bool
396 isTagChar c =
397 Char.isAlphaNum c ||
398 c=='·' ||
399 case Char.generalCategory c of
400 Char.DashPunctuation -> True
401 Char.ConnectorPunctuation -> True
402 _ -> False
403
404 {-
405 -- | Build 'Tokens' from many 'Token's.
406 tokens :: [Cell Token] -> Tokens
407 tokens ts = Seq.fromList $ Tree0 . (NodeToken <$>) <$> ts
408
409 -- | Build 'Tokens' from one 'Token'.
410 tokens1 :: Tree (Cell Node) -> Tokens
411 tokens1 = Seq.singleton
412
413 unTokenElem :: Tokens -> Maybe (Cell (ElemName,ElemAttrs,Tokens))
414 unTokenElem toks =
415 case toList $ {-Seq.dropWhileR isTokenWhite-} toks of
416 [Tree (Cell bp ep (NodePair (PairElem e as))) ts] -> Just (Cell bp ep (e,as,ts))
417 _ -> Nothing
418
419 isTokenElem :: Tokens -> Bool
420 isTokenElem toks =
421 case toList $ {-Seq.dropWhileR isTokenWhite-} toks of
422 [Tree (unCell -> NodePair PairElem{}) _] -> True
423 _ -> False
424 -}