]> Git — Sourcephile - doclang.git/blob - src/Textphile/DTC/Sym.hs
Fix megaparsec-8 update
[doclang.git] / src / Textphile / DTC / Sym.hs
1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE RankNTypes #-}
5 module Textphile.DTC.Sym where
6
7 import Control.Applicative (Applicative(..), (<$>), (<$))
8 import Control.Arrow (second)
9 import Control.Monad (void)
10 import Data.Bool (Bool(..))
11 import Data.Default.Class (Default(..))
12 import Data.Foldable (concat)
13 import Data.Monoid (Monoid(..))
14 import Data.Function (($), (.), flip)
15 import Data.Maybe (Maybe(..))
16 import Data.Semigroup (Semigroup(..))
17 import Data.TreeSeq.Strict (Tree(..), tree0)
18 import Symantic.RNC hiding (element, attribute)
19 import Text.Blaze.DTC (xmlns_dtc)
20 import qualified Data.HashMap.Strict as HM
21 import qualified Data.Text.Lazy as TL
22 import qualified Symantic.RNC as RNC
23 import qualified Symantic.XML as XML
24
25 import Textphile.RNC as RNC
26 import Textphile.XML
27 import qualified Textphile.DTC.Analyze.Index as Index
28 import qualified Textphile.DTC.Document as DTC
29 import qualified Textphile.TCT.Cell as TCT
30 import qualified Textphile.XML as XML
31
32 element :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a
33 element = RNC.element . XML.QName xmlns_dtc
34 attribute :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a
35 attribute = RNC.attribute . XML.QName ""
36
37 -- Class 'Sym_DTC'
38 -- | Use a symantic (tagless final) class to encode
39 -- both the parsing and the schema of DTC,
40 -- when repr is respectively instanciated
41 -- on 'DTC.Parser', 'RNC.NS' or 'RNC.Writer'.
42 class (Sym_RNC repr, Sym_RNC_Extra repr) => Sym_DTC repr where
43 positionXML :: repr XML.Pos
44 locationTCT :: repr TCT.Location
45 document :: repr DTC.Document
46
47 head :: repr DTC.Head
48 body :: repr DTC.Body
49 section :: repr DTC.Section
50 about :: repr DTC.About
51 include :: repr DTC.Include
52
53 block :: repr DTC.Block
54 blockBreak :: repr DTC.Block
55 blockToC :: repr DTC.Block
56 blockToF :: repr DTC.Block
57 blockIndex :: repr DTC.Block
58 blockAside :: repr DTC.Block
59 blockFigure :: repr DTC.Block
60 blockReferences :: repr DTC.Block
61 blockJudges :: repr DTC.Block
62 blockGrades :: repr DTC.Block
63 reference :: repr DTC.Reference
64
65 para :: repr DTC.Para
66 paraItem :: repr DTC.ParaItem
67 paraItems :: repr DTC.Para
68
69 plain :: repr DTC.Plain
70 plainNode :: repr (Tree DTC.PlainNode)
71
72 commonAttrs :: repr DTC.CommonAttrs
73 ident :: repr Ident
74 title :: repr DTC.Title
75 name :: repr DTC.Name
76 url :: repr URL
77 path :: repr DTC.FilePath
78 to :: repr Ident
79 id :: repr Ident
80 class_ :: repr [TL.Text]
81 rel :: repr DTC.Name
82 role :: repr DTC.Name
83
84 author :: repr DTC.Entity
85 date :: repr DTC.Date
86 entity :: repr DTC.Entity
87 link :: repr DTC.Link
88 serie :: repr DTC.Serie
89 alias :: repr DTC.Alias
90 judgment :: repr DTC.Judgment
91 choice_ :: repr DTC.Choice
92 opinion :: repr DTC.Opinion
93 judges :: repr DTC.Judges
94 judge :: repr DTC.Judge
95 grade :: repr DTC.Grade
96
97 document = rule "document" $
98 DTC.Document
99 <$> optional head
100 <*> body
101 head = rule "head" $
102 element "head" $
103 DTC.Head
104 <$> section
105 <*> body
106 body = rule "body" $
107 manySeq $
108 choice
109 [ element "section" $ Tree . DTC.BodySection <$> section <*> body
110 , tree0 . DTC.BodyBlock <$> block
111 ]
112 section = rule "section" $
113 runPermutation $
114 (\section_posXML section_locTCT section_attrs abouts ->
115 DTC.Section{section_about=mconcat abouts, ..})
116 <$$> positionXML
117 <||> locationTCT
118 <||> commonAttrs
119 <|*> about
120 about = rule "about" $
121 element "about" $
122 runPermutation $
123 DTC.About
124 <$*> title
125 <|*> alias
126 <|*> author
127 <|*> date
128 <|*> element "tag" text
129 <|*> link
130 <|*> serie
131 <|*> element "description" para
132 <|*> judgment
133 title = rule "title" $ DTC.Title <$> element "title" plain
134 name = rule "name" $ DTC.Name <$> text
135 url = rule "url" $ URL <$> text
136 path = rule "path" $ TL.unpack <$> text
137 ident = rule "ident" $ Ident <$> text
138 to = rule "to" $ attribute "to" ident
139 commonAttrs =
140 rule "commonAttrs" $
141 runPermutation $
142 DTC.CommonAttrs
143 <$?> (def, Just <$> id)
144 <|?> (def, class_)
145 id = rule "id" $ attribute "id" ident
146 class_ = rule "class" $ attribute "class" $ TL.words <$> text
147 rel = rule "rel" $ attribute "rel" name
148 role = rule "role" $ attribute "role" name
149
150 date = rule "date" $
151 element "date" $
152 runPermutation $
153 DTC.Date
154 <$?> (def, rel)
155 <|?> (def, role)
156 <||> attribute "year" int
157 <|?> (def, Just <$> attribute "month" nat1)
158 <|?> (def, Just <$> attribute "day" nat1)
159 include =
160 rule "include" $
161 element "include" $
162 runPermutation $
163 DTC.Include
164 <$?> (def, attribute "href" path)
165 block = rule "block" $
166 choice
167 [ DTC.BlockPara <$> para
168 , blockBreak
169 , blockToC
170 , blockToF
171 , blockIndex
172 , blockAside
173 , blockFigure
174 , blockReferences
175 , blockJudges
176 , blockGrades
177 {-
178 , anyElem $ \n@XmlName{..} ->
179 case xmlNameSpace of
180 "" -> figure n
181 -}
182 ]
183 blockBreak = rule "break" $
184 element "break" $
185 DTC.BlockBreak
186 <$> commonAttrs
187 blockToC =
188 rule "blockToC" $
189 element "toc" $
190 DTC.BlockToC
191 <$> positionXML
192 <*> commonAttrs
193 <*> optional (attribute "depth" nat)
194 blockToF =
195 rule "blockToF" $
196 element "tof" $
197 DTC.BlockToF
198 <$> positionXML
199 <*> commonAttrs
200 <*> option [] (
201 element "ul" $
202 many $
203 element "li" $
204 element "para" text)
205 blockIndex =
206 rule "blockIndex" $
207 element "index" $
208 DTC.BlockIndex
209 <$> positionXML
210 <*> commonAttrs
211 <*> option [] (
212 element "ul" $
213 many $
214 element "li" $
215 element "para" $
216 indexWords
217 )
218 where
219 indexWords =
220 (concat <$>) $
221 many $
222 (Index.wordify <$>) . TL.lines <$> text
223 {-
224 indexAt =
225 indexTag =
226 -}
227 blockAside =
228 rule "blockAside" $
229 element "aside" $
230 DTC.BlockAside
231 <$> positionXML
232 <*> commonAttrs
233 <*> many block
234 blockFigure =
235 rule "blockFigure" $
236 element "figure" $
237 DTC.BlockFigure
238 <$> positionXML
239 <*> attribute "type" text
240 <*> commonAttrs
241 <*> optional title
242 <*> many para
243 blockReferences =
244 rule "blockReferences" $
245 element "references" $
246 DTC.BlockReferences
247 <$> positionXML
248 <*> commonAttrs
249 <*> many reference
250 blockJudges = rule "blockJudges" $ DTC.BlockJudges <$> judges
251 blockGrades =
252 rule "blockGrades" $
253 element "grades" $
254 DTC.BlockGrades
255 <$> positionXML
256 <*> commonAttrs
257 <*> some grade
258 grade =
259 rule "grade" $
260 element "grade" $
261 DTC.Grade
262 <$> positionXML
263 <*> attribute "name" name
264 <*> attribute "color" text
265 <*> option False (True <$ attribute "default" text)
266 <*> optional title
267
268 para = rule "para" $
269 paraItems <|> -- within a <para>
270 DTC.ParaItem <$> paraItem -- without a <para>
271 paraItem =
272 rule "paraItem" $
273 choice
274 [ element "ol" $ DTC.ParaOL <$> many (element "li" $ DTC.ListItem <$> attribute "name" name <*> many para)
275 , element "ul" $ DTC.ParaUL <$> many (element "li" $ many para)
276 , element "artwork" $ DTC.ParaArtwork <$> attribute "type" text <*> text
277 , element "quote" $ DTC.ParaQuote <$> attribute "type" text <*> many para
278 , DTC.ParaPlain <$> someSeq plainNode
279 , DTC.ParaComment <$> comment
280 , DTC.ParaJudgment <$> judgment
281 ]
282 paraItems =
283 rule "paraItems" $
284 element "para" $
285 DTC.ParaItems
286 <$> positionXML
287 <*> commonAttrs
288 <*> many paraItem
289 plain = rule "plain" $ manySeq plainNode
290 plainNode =
291 rule "plainNode" $
292 choice
293 [ tree0 . DTC.PlainText <$> text
294 , element "br" $ tree0 DTC.PlainBreak <$ empty
295 , element "b" $ Tree DTC.PlainB <$> plain
296 , element "code" $ Tree DTC.PlainCode <$> plain
297 , element "del" $ Tree DTC.PlainDel <$> plain
298 , element "i" $ Tree DTC.PlainI <$> plain
299 , element "q" $ Tree DTC.PlainQ <$> plain
300 , element "sc" $ Tree DTC.PlainSC <$> plain
301 , element "span" $ Tree . DTC.PlainSpan <$> commonAttrs <*> plain
302 , element "sub" $ Tree DTC.PlainSub <$> plain
303 , element "sup" $ Tree DTC.PlainSup <$> plain
304 , element "u" $ Tree DTC.PlainU <$> plain
305 , element "note" $ tree0 . DTC.PlainNote <$> many para
306 , element "iref" $ Tree . DTC.PlainIref . Index.wordify <$> attribute "to" text <*> plain
307 , element "eref" $ Tree . DTC.PlainEref <$> attribute "to" url <*> plain
308 , element "tag" $ tree0 <$> (DTC.PlainTag <$> locationTCT <*> positionXML <*> to <*> pure False)
309 , element "tag-back" $ tree0 <$> (DTC.PlainTag <$> locationTCT <*> positionXML <*> to <*> pure True )
310 , element "at" $ tree0 <$> (DTC.PlainAt <$> locationTCT <*> positionXML <*> to <*> pure False)
311 , element "at-back" $ tree0 <$> (DTC.PlainAt <$> locationTCT <*> positionXML <*> to <*> pure True )
312 , element "ref" $
313 Tree
314 <$> (DTC.PlainRef
315 <$> locationTCT
316 <*> positionXML
317 <*> to
318 ) <*> plain
319 , element "page-ref" $
320 Tree
321 <$> (DTC.PlainPageRef
322 <$> locationTCT
323 <*> positionXML
324 <*> attribute "to" text
325 <*> optional (attribute "at" ident)
326 ) <*> plain
327 ]
328 {-
329 header =
330 rule "header" $
331 anyElem $ \n ->
332 DTC.Header (XML.nameLocal n)
333 <$> plain
334 -}
335 author = rule "author" $ element "author" entity
336 entity = rule "entity" $
337 runPermutation $
338 DTC.Entity
339 <$?> (def, rel)
340 <|?> (def, role)
341 <|?> (def, attribute "name" text)
342 <|?> (def, attribute "street" text)
343 <|?> (def, attribute "zipcode" text)
344 <|?> (def, attribute "city" text)
345 <|?> (def, attribute "region" text)
346 <|?> (def, attribute "country" text)
347 <|?> (def, attribute "email" text)
348 <|?> (def, attribute "tel" text)
349 <|?> (def, attribute "fax" text)
350 <|?> (def, Just <$> attribute "url" url)
351 <|*> element "org" entity
352 serie = rule "serie" $
353 element "serie" $
354 runPermutation $
355 DTC.Serie
356 <$?> (def, attribute "name" name)
357 <|?> (def, attribute "id" text)
358 link = rule "link" $
359 element "link" $
360 runPermutation $
361 DTC.Link
362 <$?> (def, rel)
363 <|?> (def, role)
364 <|?> (def, attribute "url" url)
365 <|?> (def, someSeq plainNode)
366 alias = rule "alias" $
367 element "alias" $
368 DTC.Alias
369 <$> commonAttrs
370 <*> title
371 reference = rule "reference" $
372 element "reference" $
373 DTC.Reference
374 <$> positionXML
375 <*> locationTCT
376 <*> id
377 <*> about
378
379 judgment =
380 rule "judgment" $
381 element "judgment" $
382 attrs
383 <*> many choice_
384 where
385 attrs =
386 runPermutation $
387 DTC.Judgment def -- def def
388 <$$> positionXML
389 <||> locationTCT
390 <||> attribute "judges" ident
391 <||> attribute "grades" ident
392 <|?> (def, Just <$> attribute "importance" rationalPositive)
393 <|?> (def, Just <$> attribute "hide" bool)
394 -- <|?> (def, Just <$> attribute "importance" (pure 0))
395 <|?> (def, Just <$> title)
396 choice_ =
397 rule "choice" $
398 element "choice" $
399 DTC.Choice
400 <$> locationTCT
401 <*> positionXML
402 <*> optional title
403 <*> many opinion
404 opinion =
405 rule "opinion" $
406 element "opinion" $
407 (runPermutation $ DTC.Opinion
408 <$$> locationTCT
409 <||> positionXML
410 <|?> (def, attribute "judge" name)
411 <|?> (def, attribute "grade" name)
412 <|?> (def, Just <$> attribute "default" name)
413 <|?> (def, Just <$> attribute "importance" rationalPositive))
414 -- <|?> (def, Just <$> attribute "importance" (pure 0)))
415 <*> optional title
416 judges =
417 rule "judges" $
418 element "judges" $
419 DTC.Judges
420 <$> locationTCT
421 <*> positionXML
422 <*> commonAttrs
423 <*> judgesByName
424 where
425 judgesByName =
426 HM.fromListWith (flip (<>)) .
427 ((\j@DTC.Judge{..} -> (judge_name, pure j)) <$>)
428 <$> some judge
429 judge =
430 rule "judge" $
431 element "judge" $
432 DTC.Judge
433 <$> locationTCT
434 <*> positionXML
435 <*> attribute "name" name
436 <*> optional title
437 <*> defaultGrades
438 where
439 defaultGrades =
440 HM.fromListWith (flip (<>)) .
441 (second pure <$>)
442 <$> many defaultGrade
443 defaultGrade =
444 rule "default" $
445 element "default" $
446 (,)
447 <$> attribute "grades" ident
448 <*> attribute "grade" (DTC.Name <$> text)
449
450 instance Sym_DTC RNC.NS where
451 positionXML = mempty
452 locationTCT = mempty
453 instance Sym_DTC RNC.Writer where
454 positionXML = RNC.writeText ""
455 locationTCT = RNC.writeText ""
456
457 -- | RNC schema for DTC
458 schema :: forall repr. Sym_DTC repr => [repr ()]
459 schema =
460 [ void $ RNC.namespace Nothing xmlns_dtc
461
462 , void $ document
463 , void $ about
464 , void $ author
465 , void $ date
466 , void $ entity
467 , void $ link
468 , void $ serie
469 , void $ alias
470 , void $ judgment
471 , void $ choice_
472 , void $ opinion
473 , void $ judges
474 , void $ judge
475 , void $ grade
476
477 , void $ head
478 , void $ body
479 , void $ section
480 , void $ include
481
482 , void $ block
483 , void $ blockToC
484 , void $ blockToF
485 , void $ blockIndex
486 , void $ blockFigure
487 , void $ blockReferences
488 , void $ reference
489
490 , void $ para
491 , void $ paraItem
492 , void $ paraItems
493
494 , void $ plain
495 , void $ plainNode
496
497 , void $ commonAttrs
498 , void $ ident
499 , void $ title
500 , void $ name
501 , void $ url
502 , void $ path
503 , void $ to
504 , void $ id
505 , void $ class_
506 , void $ rel
507 ]