]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Document.hs
Update to megaparsec-7 and new symantic-xml
[doclang.git] / Hdoc / DTC / Document.hs
1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE DisambiguateRecordFields #-}
3 {-# LANGUAGE DuplicateRecordFields #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 module Hdoc.DTC.Document
8 ( module Hdoc.DTC.Document
9 , Ident(..), URL(..), Nat(..), Nat1(..)
10 , succNat, succNat1
11 , FilePath
12 ) where
13
14 import Control.Applicative (Applicative(..))
15 import Data.Bool
16 import Data.Default.Class (Default(..))
17 import Data.Default.Instances.Containers ()
18 import Data.Eq (Eq(..))
19 import Control.Monad (Monad(..))
20 import Data.Foldable (Foldable(..))
21 import Data.Function (on, ($), (.))
22 import Data.Hashable (Hashable(..))
23 import Data.Int (Int)
24 import Data.Maybe (Maybe(..))
25 import Data.Monoid (Monoid(..))
26 import Data.Ord (Ord(..))
27 import Data.Semigroup (Semigroup(..))
28 import Data.Sequence (Seq(..))
29 import Data.String (IsString)
30 import GHC.Generics (Generic)
31 import System.FilePath (FilePath)
32 import Text.Show (Show)
33 import qualified Data.Char as Char
34 import qualified Data.HashMap.Strict as HM
35 import qualified Data.List as List
36 import qualified Data.Text.Lazy as TL
37 import qualified Data.TreeMap.Strict as TM
38 import qualified Data.TreeSeq.Strict as TS
39 import qualified Majority.Judgment as MJ
40
41 import Hdoc.Utils (Nat(..), Nat1(..), succNat, succNat1)
42 import Hdoc.XML (Ident(..), URL(..))
43 import qualified Hdoc.XML as XML
44 import qualified Hdoc.TCT.Cell as TCT
45
46 -- * Type 'Document'
47 data Document = Document
48 { document_head :: !(Maybe Head)
49 , document_body :: !Body
50 } deriving (Eq,Show)
51
52 -- * Type 'Head'
53 data Head = Head
54 { head_section :: !Section
55 , head_body :: !Body
56 } deriving (Eq,Show)
57 instance Default Head where
58 def = Head
59 { head_section = def
60 , head_body = def
61 }
62 instance Ord Head where
63 compare = compare `on` head_section
64
65 {-
66 -- * Type 'Header'
67 data Header = Header
68 { header_name :: !TL.Text
69 , header_value :: !Plain
70 } deriving (Eq,Show)
71 -}
72
73 -- * Type 'Body'
74 type Body = TS.Trees BodyNode
75
76 -- ** Type 'BodyNode'
77 data BodyNode
78 = BodySection !Section -- ^ node
79 | BodyBlock !Block -- ^ leaf
80 deriving (Eq,Show)
81
82 -- Type 'Section'
83 data Section = Section
84 { section_posXML :: !XML.Pos
85 , section_locTCT :: !TCT.Location
86 , section_attrs :: !CommonAttrs
87 , section_about :: !About
88 } deriving (Eq,Show)
89 instance Ord Section where
90 compare = compare `on` section_posXML
91 instance Default Section where
92 def = Section
93 { section_posXML = def
94 , section_locTCT = def
95 , section_attrs = def
96 , section_about = def
97 }
98
99 -- * Type 'About'
100 data About = About
101 { about_titles :: ![Title]
102 , about_aliases :: ![Alias]
103 , about_authors :: ![Entity]
104 , about_dates :: ![Date]
105 , about_tags :: ![TL.Text]
106 , about_links :: ![Link]
107 , about_series :: ![Serie]
108 , about_description :: ![Para]
109 , about_judgments :: ![Judgment]
110 } deriving (Eq,Show)
111 instance Default About where
112 def = About
113 { about_titles = def
114 , about_aliases = def
115 , about_dates = def
116 , about_authors = def
117 , about_tags = def
118 , about_links = def
119 , about_series = def
120 , about_description = def
121 , about_judgments = def
122 }
123 instance Semigroup About where
124 x <> y = About
125 { about_titles = about_titles x <> about_titles y
126 , about_aliases = about_aliases x <> about_aliases y
127 , about_dates = about_dates x <> about_dates y
128 , about_authors = about_authors x <> about_authors y
129 , about_tags = about_tags x <> about_tags y
130 , about_links = about_links x <> about_links y
131 , about_series = about_series x <> about_series y
132 , about_description = about_description x <> about_description y
133 , about_judgments = about_judgments x <> about_judgments y
134 }
135 instance Monoid About where
136 mempty = def
137 mappend = (<>)
138
139 -- * Type 'Block'
140 data Block
141 = BlockPara Para
142 | BlockBreak { attrs :: !CommonAttrs }
143 | BlockToC { posXML :: !XML.Pos
144 , attrs :: !CommonAttrs
145 , depth :: !(Maybe Nat)
146 }
147 | BlockToF { posXML :: !XML.Pos
148 , attrs :: !CommonAttrs
149 , types :: ![TL.Text]
150 }
151 | BlockAside { posXML :: !XML.Pos
152 , attrs :: !CommonAttrs
153 , blocks :: ![Block]
154 }
155 | BlockFigure { posXML :: !XML.Pos
156 , type_ :: !TL.Text
157 , attrs :: !CommonAttrs
158 , mayTitle :: !(Maybe Title)
159 , paras :: ![Para]
160 }
161 | BlockIndex { posXML :: !XML.Pos
162 , attrs :: !CommonAttrs
163 , index :: !Terms
164 }
165 | BlockReferences { posXML :: !XML.Pos
166 , attrs :: !CommonAttrs
167 , refs :: ![Reference]
168 } -- FIXME: move to ParaReferences?
169 | BlockJudges !Judges
170 | BlockGrades { posXML :: !XML.Pos
171 , attrs :: !CommonAttrs
172 , scale :: ![Grade]
173 }
174 deriving (Eq,Show)
175
176 -- * Type 'Index'
177 type Index = TM.TreeMap Word Pos
178
179 -- * Type 'Judgment'
180 data Judgment = Judgment
181 { judgment_opinionsByChoice :: !(Maybe (MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)))
182 -- , judgment_judges :: !(Maybe Judges)
183 -- , judgment_grades :: !(Maybe (MJ.Grades (MJ.Ranked Grade)))
184 , judgment_posXML :: !XML.Pos
185 , judgment_locTCT :: !TCT.Location
186 , judgment_judgesId :: !Ident
187 , judgment_gradesId :: !Ident
188 , judgment_importance :: !(Maybe MJ.Share)
189 , judgment_hide :: !(Maybe Bool)
190 , judgment_question :: !(Maybe Title)
191 , judgment_choices :: ![Choice]
192 } deriving (Eq,Show)
193 instance Default Judgment where
194 def = Judgment
195 { judgment_opinionsByChoice = def
196 -- , judgment_judges = def
197 -- , judgment_grades = def
198 , judgment_posXML = def
199 , judgment_locTCT = def
200 , judgment_judgesId = def
201 , judgment_gradesId = def
202 , judgment_importance = def
203 , judgment_hide = def
204 , judgment_question = def
205 , judgment_choices = def
206 }
207
208 -- ** Type 'JudgmentKey'
209 data JudgmentKey = JudgmentKey
210 { judgmentKey_judgesId :: !Ident
211 , judgmentKey_gradesId :: !Ident
212 , judgmentKey_question :: !(Maybe Title)
213 } deriving (Eq,Show,Generic)
214 instance Hashable JudgmentKey
215
216 -- ** Type 'ErrorJudgment'
217 data ErrorJudgment
218 = ErrorJudgment_Judges
219 | ErrorJudgment_Grades
220 deriving (Eq,Show)
221
222 -- ** Type 'Judges'
223 data Judges = Judges
224 { judges_locTCT :: !TCT.Location
225 , judges_posXML :: !XML.Pos
226 , judges_attrs :: !CommonAttrs
227 , judges_byName :: !(HM.HashMap Name [Judge])
228 } deriving (Eq,Show)
229
230 -- ** Type 'Judge'
231 data Judge = Judge
232 { judge_locTCT :: !TCT.Location
233 , judge_posXML :: !XML.Pos
234 , judge_name :: !Name
235 , judge_title :: !(Maybe Title)
236 , judge_defaultGrades :: !(HM.HashMap Ident [Name])
237 } deriving (Eq,Show)
238
239 -- ** Type 'Grade'
240 data Grade = Grade
241 { grade_posXML :: !XML.Pos
242 , grade_name :: !Name
243 , grade_color :: !TL.Text
244 , grade_isDefault :: !Bool
245 , grade_title :: !(Maybe Title)
246 } deriving (Eq,Show)
247
248 -- ** Type 'Choice'
249 data Choice = Choice
250 { choice_locTCT :: TCT.Location
251 , choice_posXML :: XML.Pos
252 , choice_title :: !(Maybe Title)
253 , choice_opinions :: ![Opinion]
254 } deriving (Show)
255 instance Eq Choice where
256 (==) = (==)`on`choice_title
257 instance Hashable Choice where
258 hashWithSalt s Choice{..} =
259 hashWithSalt s choice_title
260
261 -- ** Type 'Opinion'
262 data Opinion = Opinion
263 { opinion_locTCT :: !TCT.Location
264 , opinion_posXML :: !XML.Pos
265 , opinion_judge :: !Name
266 , opinion_grade :: !Name
267 , opinion_default :: !(Maybe Name)
268 , opinion_importance :: !(Maybe MJ.Share)
269 , opinion_comment :: !(Maybe Title)
270 } deriving (Eq,Show)
271
272 -- * Type 'Para'
273 data Para
274 = ParaItem { item :: !ParaItem }
275 | ParaItems { posXML :: !XML.Pos
276 , attrs :: !CommonAttrs
277 , items :: ![ParaItem]
278 }
279 deriving (Eq,Show)
280
281 -- ** Type 'ParaItem'
282 data ParaItem
283 = ParaPlain !Plain
284 | ParaComment !TL.Text
285 | ParaOL ![ListItem]
286 | ParaUL ![[Para]]
287 | ParaQuote { type_ :: !TL.Text
288 , paras :: ![Para]
289 }
290 | ParaArtwork { type_ :: !TL.Text
291 , text :: !TL.Text
292 }
293 | ParaJudgment !Judgment
294 deriving (Eq,Show)
295
296 -- *** Type 'ListItem'
297 data ListItem = ListItem
298 { name :: !Name
299 , paras :: ![Para]
300 } deriving (Eq,Show)
301
302 -- * Type 'Plain'
303 type Plain = TS.Trees PlainNode
304
305 -- ** Type 'PlainNode'
306 data PlainNode
307 -- Nodes
308 = PlainB -- ^ Bold
309 | PlainCode -- ^ Code (monospaced)
310 | PlainDel -- ^ Deleted (crossed-over)
311 | PlainI -- ^ Italic
312 | PlainGroup -- ^ Group subTrees (neutral)
313 | PlainQ -- ^ Quoted
314 | PlainSC -- ^ Small Caps
315 | PlainSub -- ^ Subscript
316 | PlainSup -- ^ Superscript
317 | PlainU -- ^ Underlined
318 | PlainEref { eref_href :: !URL } -- ^ External reference
319 | PlainIref { iref_term :: !Words
320 } -- ^ Index reference
321 | PlainRef { ref_locTCT :: !TCT.Location
322 , ref_posXML :: !XML.Pos
323 , ref_ident :: !Ident
324 } -- ^ Reference reference
325 | PlainPageRef { pageRef_locTCT :: !TCT.Location
326 , pageRef_posXML :: !XML.Pos
327 , pageRef_path :: !PathPage
328 , pageRef_at :: !(Maybe Ident)
329 } -- ^ Page reference
330 | PlainSpan { attrs :: !CommonAttrs } -- ^ Neutral node
331 -- Leafs
332 | PlainBreak -- ^ Line break (\n)
333 | PlainText TL.Text
334 | PlainNote { note_paras :: ![Para]
335 } -- ^ Footnote
336 | PlainTag { tag_locTCT :: !TCT.Location
337 , tag_posXML :: !XML.Pos
338 , tag_ident :: !Ident
339 , tag_back :: !Bool
340 }
341 | PlainAt { at_locTCT :: !TCT.Location
342 , at_posXML :: !XML.Pos
343 , at_ident :: !Ident
344 , at_back :: !Bool
345 }
346 deriving (Eq,Show)
347
348 {-
349 -- * Type 'To'
350 data To
351 = To_At !Ident
352 | To_Tag !Ident
353 deriving (Eq,Show)
354
355 -- * Type 'Tag'
356 newtype Tag = Tag TL.Text
357 deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)
358 -}
359
360 {-
361 -- * Type 'ErrorTarget'
362 data ErrorTarget
363 = ErrorTarget_Unknown !Nat1
364 | ErrorTarget_Ambiguous !(Maybe Nat1)
365 deriving (Eq,Show)
366
367 -- * Type 'ErrorAnchor'
368 data ErrorAnchor
369 = ErrorAnchor_Ambiguous !Nat1
370 deriving (Eq,Show)
371 -}
372
373 -- * Type 'CommonAttrs'
374 data CommonAttrs = CommonAttrs
375 { attrs_id :: !(Maybe Ident)
376 , attrs_classes :: ![TL.Text]
377 } deriving (Eq,Ord,Show)
378 instance Default CommonAttrs where
379 def = CommonAttrs
380 { attrs_id = def
381 , attrs_classes = def
382 }
383
384 -- ** Type 'Anchor'
385 data Anchor = Anchor
386 { anchor_section :: !XML.Pos
387 , anchor_count :: !Nat1
388 } deriving (Eq,Ord,Show)
389
390 -- * Type 'PathPage'
391 type PathPage = TL.Text
392
393 -- * Type 'Name'
394 newtype Name = Name { unName :: TL.Text }
395 deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)
396
397 -- * Type 'Title'
398 newtype Title = Title { unTitle :: Plain }
399 deriving (Show,Semigroup,Monoid,Default)
400 instance Eq Title where
401 (==) = (==) `on` similarPlain . unTitle
402 -- | Return a similar version of a 'Plain' by removing:
403 --
404 -- * parsing residues ('PlainGroup'),
405 -- * notes ('PlainNote'),
406 -- * and position specific annotations ('Ident' and 'Anchor').
407 similarPlain :: Plain -> Plain
408 similarPlain = foldMap $ \(TS.Tree n ts) ->
409 let skip = similarPlain ts in
410 let keep = pure $ TS.Tree n $ skip in
411 case n of
412 PlainGroup -> skip
413 PlainNote{} -> skip
414 PlainIref{..} -> keep
415 PlainRef{..} -> pure $ TS.Tree PlainRef{ ref_locTCT = def
416 , ref_posXML = def
417 , .. } skip
418 PlainPageRef{..} -> pure $ TS.Tree PlainPageRef{ pageRef_locTCT = def
419 , pageRef_posXML = def
420 , .. } skip
421 PlainSpan attrs -> pure $ TS.Tree n' skip
422 where n' = PlainSpan{attrs = CommonAttrs{ attrs_id = Nothing
423 , attrs_classes = List.sort $ attrs_classes attrs }}
424 PlainB -> keep
425 PlainCode -> keep
426 PlainDel -> keep
427 PlainI -> keep
428 PlainQ -> keep
429 PlainSC -> keep
430 PlainSub -> keep
431 PlainSup -> keep
432 PlainU -> keep
433 PlainEref{..} -> keep
434 PlainAt{..} -> pure $ TS.Tree PlainAt{at_locTCT=def, at_posXML=def, ..} skip
435 PlainTag{..} -> pure $ TS.Tree PlainTag{tag_locTCT=def, tag_posXML=def, ..} skip
436 PlainBreak -> keep
437 PlainText{} -> keep
438 -- | Return the same hash if 'similarPlain' is applied on the 'Title' before hashing.
439 --
440 -- Warning: when using the key of HashMap or HashSet,
441 -- only the data taken into account by this 'Hashable' instance is reliable.
442 instance Hashable Title where
443 hashWithSalt salt (Title ps) = hs salt ps
444 where
445 hs = foldr h
446 h (TS.Tree n ts) s =
447 (`hs` ts) $
448 case n of
449 PlainGroup -> s
450 PlainNote{} -> s
451 PlainIref{..} -> s`hashWithSalt`(0::Int)`hashWithSalt`iref_term
452 PlainTag{..} -> s`hashWithSalt`(1::Int)`hashWithSalt`tag_ident`hashWithSalt`tag_back
453 PlainAt{..} -> s`hashWithSalt`(2::Int)`hashWithSalt`at_ident`hashWithSalt`at_back
454 PlainSpan{..} -> s`hashWithSalt`(3::Int)`hashWithSalt`List.sort (attrs_classes attrs)
455 PlainB -> s`hashWithSalt`(4::Int)
456 PlainCode -> s`hashWithSalt`(5::Int)
457 PlainDel -> s`hashWithSalt`(6::Int)
458 PlainI -> s`hashWithSalt`(7::Int)
459 PlainQ -> s`hashWithSalt`(8::Int)
460 PlainSC -> s`hashWithSalt`(9::Int)
461 PlainSub -> s`hashWithSalt`(10::Int)
462 PlainSup -> s`hashWithSalt`(11::Int)
463 PlainU -> s`hashWithSalt`(12::Int)
464 PlainEref{..} -> s`hashWithSalt`(13::Int)`hashWithSalt`eref_href
465 PlainRef{..} -> s`hashWithSalt`(14::Int)`hashWithSalt`ref_ident
466 PlainPageRef{..} -> s`hashWithSalt`(15::Int)`hashWithSalt`pageRef_at`hashWithSalt`pageRef_path
467 PlainBreak -> s`hashWithSalt`(16::Int)
468 PlainText t -> s`hashWithSalt`(17::Int)`hashWithSalt`t
469
470 -- * Type 'Entity'
471 data Entity = Entity
472 { entity_rel :: !Name
473 , entity_role :: !Name
474 , entity_name :: !TL.Text
475 , entity_street :: !TL.Text
476 , entity_zipcode :: !TL.Text
477 , entity_city :: !TL.Text
478 , entity_region :: !TL.Text
479 , entity_country :: !TL.Text
480 , entity_email :: !TL.Text
481 , entity_tel :: !TL.Text
482 , entity_fax :: !TL.Text
483 , entity_url :: !(Maybe URL)
484 , entity_org :: ![Entity]
485 } deriving (Eq,Show)
486 instance Default Entity where
487 def = Entity
488 { entity_rel = def
489 , entity_role = def
490 , entity_name = def
491 , entity_street = def
492 , entity_zipcode = def
493 , entity_city = def
494 , entity_region = def
495 , entity_country = def
496 , entity_email = def
497 , entity_tel = def
498 , entity_fax = def
499 , entity_url = def
500 , entity_org = def
501 }
502
503 -- * Type 'Include'
504 newtype Include = Include
505 { include_href :: FilePath
506 } deriving (Eq,Show)
507 instance Default Include where
508 def = Include
509 { include_href = def
510 }
511
512 -- * Type 'Reference'
513 data Reference = Reference
514 { reference_posXML :: !XML.Pos
515 , reference_locTCT :: !TCT.Location
516 , reference_id :: !Ident
517 , reference_about :: !About
518 } deriving (Eq,Show)
519
520 -- * Type 'Date'
521 data Date = Date
522 { date_rel :: !Name
523 , date_role :: !Name
524 , date_year :: !Int
525 , date_month :: !(Maybe Nat1)
526 , date_day :: !(Maybe Nat1)
527 } deriving (Eq,Show)
528 instance Default Date where
529 def = Date
530 { date_rel = def
531 , date_role = def
532 , date_year = 1970
533 , date_month = Just (Nat1 01)
534 , date_day = Just (Nat1 01)
535 }
536 instance Semigroup Date where
537 _x <> y = y
538
539 -- * Type 'Link'
540 data Link = Link
541 { link_rel :: !Name
542 , link_role :: !Name
543 , link_url :: !URL
544 , link_plain :: !Plain
545 -- , link_type :: !(Maybe TL.Text)
546 } deriving (Eq,Show)
547 instance Default Link where
548 def = Link
549 { link_rel = def
550 , link_role = def
551 , link_url = def
552 , link_plain = def
553 -- , link_type = def
554 }
555
556 -- * Type 'Alias'
557 data Alias = Alias
558 { alias_attrs :: !CommonAttrs
559 , alias_title :: !Title
560 } deriving (Eq,Show)
561
562 -- * Type 'Serie'
563 data Serie = Serie
564 { serie_name :: !Name
565 , serie_id :: !TL.Text
566 } deriving (Eq,Show)
567 instance Default Serie where
568 def = Serie
569 { serie_name = def
570 , serie_id = def
571 }
572
573 -- | Builtins 'URL' recognized from |Serie|'s 'name'.
574 urlSerie :: Serie -> Maybe URL
575 urlSerie Serie{..} =
576 case serie_name of
577 "RFC" | TL.all Char.isDigit serie_id ->
578 Just $ URL $ "https://tools.ietf.org/html/rfc"<>serie_id
579 "DOI" -> Just $ URL $ "https://dx.doi.org/"<>serie_id
580 _ -> Nothing
581
582 -- * Type 'Word'
583 type Word = TL.Text
584
585 -- ** Type 'Words'
586 type Words = [WordOrSpace]
587
588 -- *** Type 'WordOrSpace'
589 data WordOrSpace
590 = Word !Word
591 | Space
592 deriving (Eq,Ord,Show,Generic)
593 instance Hashable WordOrSpace
594
595 -- ** Type 'Terms'
596 type Terms = [Aliases]
597
598 -- *** Type 'Aliases'
599 type Aliases = [Words]
600
601 -- ** Type 'PathWord'
602 type PathWord = TM.Path Word
603
604 pathFromWords :: Words -> Maybe PathWord
605 pathFromWords ws =
606 case ws >>= unSpace of
607 p:ps | not (TL.null p) -> Just (TM.path p ps)
608 _ -> Nothing
609 where
610 unSpace = \case
611 Space -> []
612 Word w -> [w]
613
614 -- * Type 'Location'
615 type Location = (TCT.Location, XML.Pos)
616
617 -- * Type 'Pos'
618 type Pos = Seq Section