]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Document.hs
XML: use 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 | PlainSpan { attrs :: !CommonAttrs } -- ^ Neutral node
326 -- Leafs
327 | PlainBreak -- ^ Line break (\n)
328 | PlainText TL.Text
329 | PlainNote { note_paras :: ![Para]
330 } -- ^ Footnote
331 | PlainTag { tag_locTCT :: !TCT.Location
332 , tag_posXML :: !XML.Pos
333 , tag_ident :: !Ident
334 , tag_back :: !Bool
335 }
336 | PlainAt { at_locTCT :: !TCT.Location
337 , at_posXML :: !XML.Pos
338 , at_ident :: !Ident
339 , at_back :: !Bool
340 }
341 deriving (Eq,Show)
342
343 {-
344 -- * Type 'To'
345 data To
346 = To_At !Ident
347 | To_Tag !Ident
348 deriving (Eq,Show)
349
350 -- * Type 'Tag'
351 newtype Tag = Tag TL.Text
352 deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)
353 -}
354
355 {-
356 -- * Type 'ErrorTarget'
357 data ErrorTarget
358 = ErrorTarget_Unknown !Nat1
359 | ErrorTarget_Ambiguous !(Maybe Nat1)
360 deriving (Eq,Show)
361
362 -- * Type 'ErrorAnchor'
363 data ErrorAnchor
364 = ErrorAnchor_Ambiguous !Nat1
365 deriving (Eq,Show)
366 -}
367
368 -- * Type 'CommonAttrs'
369 data CommonAttrs = CommonAttrs
370 { attrs_id :: !(Maybe Ident)
371 , attrs_classes :: ![TL.Text]
372 } deriving (Eq,Ord,Show)
373 instance Default CommonAttrs where
374 def = CommonAttrs
375 { attrs_id = def
376 , attrs_classes = def
377 }
378
379 -- ** Type 'Anchor'
380 data Anchor = Anchor
381 { anchor_section :: !XML.Pos
382 , anchor_count :: !Nat1
383 } deriving (Eq,Ord,Show)
384
385 -- * Type 'Name'
386 newtype Name = Name { unName :: TL.Text }
387 deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)
388
389 -- * Type 'Title'
390 newtype Title = Title { unTitle :: Plain }
391 deriving (Show,Semigroup,Monoid,Default)
392 instance Eq Title where
393 (==) = (==) `on` similarPlain . unTitle
394 -- | Return a similar version of a 'Plain' by removing:
395 --
396 -- * parsing residues ('PlainGroup'),
397 -- * notes ('PlainNote'),
398 -- * and position specific annotations ('Ident' and 'Anchor').
399 similarPlain :: Plain -> Plain
400 similarPlain = foldMap $ \(TS.Tree n ts) ->
401 let skip = similarPlain ts in
402 let keep = pure $ TS.Tree n $ skip in
403 case n of
404 PlainGroup -> skip
405 PlainNote{} -> skip
406 PlainIref{..} -> keep
407 PlainRef{..} -> pure $ TS.Tree PlainRef{ ref_locTCT = def
408 , ref_posXML = def
409 , .. } skip
410 PlainSpan attrs -> pure $ TS.Tree n' skip
411 where n' = PlainSpan{attrs = CommonAttrs{ attrs_id = Nothing
412 , attrs_classes = List.sort $ attrs_classes attrs }}
413 PlainB -> keep
414 PlainCode -> keep
415 PlainDel -> keep
416 PlainI -> keep
417 PlainQ -> keep
418 PlainSC -> keep
419 PlainSub -> keep
420 PlainSup -> keep
421 PlainU -> keep
422 PlainEref{..} -> keep
423 PlainAt{..} -> pure $ TS.Tree PlainAt{at_locTCT=def, at_posXML=def, ..} skip
424 PlainTag{..} -> pure $ TS.Tree PlainTag{tag_locTCT=def, tag_posXML=def, ..} skip
425 PlainBreak -> keep
426 PlainText{} -> keep
427 -- | Return the same hash if 'similarPlain' is applied on the 'Title' before hashing.
428 --
429 -- Warning: when using the key of HashMap or HashSet,
430 -- only the data taken into account by this 'Hashable' instance is reliable.
431 instance Hashable Title where
432 hashWithSalt salt (Title ps) = hs salt ps
433 where
434 hs = foldr h
435 h (TS.Tree n ts) s =
436 (`hs` ts) $
437 case n of
438 PlainGroup -> s
439 PlainNote{} -> s
440 PlainIref{..} -> s`hashWithSalt`(0::Int)`hashWithSalt`iref_term
441 PlainTag{..} -> s`hashWithSalt`(1::Int)`hashWithSalt`tag_ident`hashWithSalt`tag_back
442 PlainAt{..} -> s`hashWithSalt`(2::Int)`hashWithSalt`at_ident`hashWithSalt`at_back
443 PlainSpan{..} -> s`hashWithSalt`(3::Int)`hashWithSalt`List.sort (attrs_classes attrs)
444 PlainB -> s`hashWithSalt`(4::Int)
445 PlainCode -> s`hashWithSalt`(5::Int)
446 PlainDel -> s`hashWithSalt`(6::Int)
447 PlainI -> s`hashWithSalt`(7::Int)
448 PlainQ -> s`hashWithSalt`(8::Int)
449 PlainSC -> s`hashWithSalt`(9::Int)
450 PlainSub -> s`hashWithSalt`(10::Int)
451 PlainSup -> s`hashWithSalt`(11::Int)
452 PlainU -> s`hashWithSalt`(12::Int)
453 PlainEref{..} -> s`hashWithSalt`(13::Int)`hashWithSalt`eref_href
454 PlainRef{..} -> s`hashWithSalt`(14::Int)`hashWithSalt`ref_ident
455 PlainBreak -> s`hashWithSalt`(15::Int)
456 PlainText t -> s`hashWithSalt`(16::Int)`hashWithSalt`t
457
458 -- * Type 'Entity'
459 data Entity = Entity
460 { entity_rel :: !Name
461 , entity_role :: !Name
462 , entity_name :: !TL.Text
463 , entity_street :: !TL.Text
464 , entity_zipcode :: !TL.Text
465 , entity_city :: !TL.Text
466 , entity_region :: !TL.Text
467 , entity_country :: !TL.Text
468 , entity_email :: !TL.Text
469 , entity_tel :: !TL.Text
470 , entity_fax :: !TL.Text
471 , entity_url :: !(Maybe URL)
472 , entity_org :: ![Entity]
473 } deriving (Eq,Show)
474 instance Default Entity where
475 def = Entity
476 { entity_rel = def
477 , entity_role = def
478 , entity_name = def
479 , entity_street = def
480 , entity_zipcode = def
481 , entity_city = def
482 , entity_region = def
483 , entity_country = def
484 , entity_email = def
485 , entity_tel = def
486 , entity_fax = def
487 , entity_url = def
488 , entity_org = def
489 }
490
491 -- * Type 'Include'
492 newtype Include = Include
493 { include_href :: FilePath
494 } deriving (Eq,Show)
495 instance Default Include where
496 def = Include
497 { include_href = def
498 }
499
500 -- * Type 'Reference'
501 data Reference = Reference
502 { reference_posXML :: !XML.Pos
503 , reference_locTCT :: !TCT.Location
504 , reference_id :: !Ident
505 , reference_about :: !About
506 } deriving (Eq,Show)
507
508 -- * Type 'Date'
509 data Date = Date
510 { date_rel :: !Name
511 , date_role :: !Name
512 , date_year :: !Int
513 , date_month :: !(Maybe Nat1)
514 , date_day :: !(Maybe Nat1)
515 } deriving (Eq,Show)
516 instance Default Date where
517 def = Date
518 { date_rel = def
519 , date_role = def
520 , date_year = 1970
521 , date_month = Just (Nat1 01)
522 , date_day = Just (Nat1 01)
523 }
524 instance Semigroup Date where
525 _x <> y = y
526
527 -- * Type 'Link'
528 data Link = Link
529 { link_rel :: !Name
530 , link_role :: !Name
531 , link_url :: !URL
532 , link_plain :: !Plain
533 -- , link_type :: !(Maybe TL.Text)
534 } deriving (Eq,Show)
535 instance Default Link where
536 def = Link
537 { link_rel = def
538 , link_role = def
539 , link_url = def
540 , link_plain = def
541 -- , link_type = def
542 }
543
544 -- * Type 'Alias'
545 data Alias = Alias
546 { alias_attrs :: !CommonAttrs
547 , alias_title :: !Title
548 } deriving (Eq,Show)
549
550 -- * Type 'Serie'
551 data Serie = Serie
552 { serie_name :: !Name
553 , serie_id :: !TL.Text
554 } deriving (Eq,Show)
555 instance Default Serie where
556 def = Serie
557 { serie_name = def
558 , serie_id = def
559 }
560
561 -- | Builtins 'URL' recognized from |Serie|'s 'name'.
562 urlSerie :: Serie -> Maybe URL
563 urlSerie Serie{..} =
564 case serie_name of
565 "RFC" | TL.all Char.isDigit serie_id ->
566 Just $ URL $ "https://tools.ietf.org/html/rfc"<>serie_id
567 "DOI" -> Just $ URL $ "https://dx.doi.org/"<>serie_id
568 _ -> Nothing
569
570 -- * Type 'Word'
571 type Word = TL.Text
572
573 -- ** Type 'Words'
574 type Words = [WordOrSpace]
575
576 -- *** Type 'WordOrSpace'
577 data WordOrSpace
578 = Word !Word
579 | Space
580 deriving (Eq,Ord,Show,Generic)
581 instance Hashable WordOrSpace
582
583 -- ** Type 'Terms'
584 type Terms = [Aliases]
585
586 -- *** Type 'Aliases'
587 type Aliases = [Words]
588
589 -- ** Type 'PathWord'
590 type PathWord = TM.Path Word
591
592 pathFromWords :: Words -> Maybe PathWord
593 pathFromWords ws =
594 case ws >>= unSpace of
595 p:ps | not (TL.null p) -> Just (TM.path p ps)
596 _ -> Nothing
597 where
598 unSpace = \case
599 Space -> []
600 Word w -> [w]
601
602 -- * Type 'Location'
603 type Location = (TCT.Location, XML.Pos)
604
605 -- * Type 'Pos'
606 type Pos = Seq Section