]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Document.hs
Fix TCT Reference ID syntax.
[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.TreeSeq.Strict as TS
38 import qualified Data.TreeMap.Strict as TM
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 { head :: !Head
49 , body :: !Body
50 } deriving (Eq,Show)
51 instance Default Document where
52 def = Document
53 { head = def
54 , body = def
55 }
56
57 -- * Type 'Head'
58 data Head = Head
59 { head_about :: !About
60 , head_judgments :: ![Judgment]
61 -- [(Judgment, [Tree.Tree (Maybe MJ.Share, [Choice])])]
62 } deriving (Eq,Show)
63 instance Default Head where
64 def = Head
65 { head_about = def
66 , head_judgments = def
67 }
68
69 -- ** Type 'About'
70 data About = About
71 { about_titles :: ![Title]
72 , about_url :: !(Maybe URL)
73 , about_authors :: ![Entity]
74 , about_editor :: !(Maybe Entity)
75 , about_date :: !(Maybe Date)
76 , about_tags :: ![TL.Text]
77 , about_links :: ![Link]
78 , about_series :: ![Serie]
79 , about_description :: !(Maybe Para)
80 , about_headers :: ![Header]
81 } deriving (Eq,Show)
82 instance Default About where
83 def = About
84 { about_titles = def
85 , about_url = def
86 , about_date = def
87 , about_editor = def
88 , about_authors = def
89 , about_tags = def
90 , about_links = def
91 , about_series = def
92 , about_description = def
93 , about_headers = def
94 }
95
96 -- * Type 'Header'
97 data Header = Header
98 { header_name :: !TL.Text
99 , header_value :: !Plain
100 } deriving (Eq,Show)
101
102 -- * Type 'Body'
103 type Body = TS.Trees BodyNode
104
105 -- ** Type 'BodyNode'
106 data BodyNode
107 = BodySection !Section -- ^ node
108 | BodyBlock !Block -- ^ leaf
109 deriving (Eq,Show)
110
111 -- Type 'Section'
112 data Section = Section
113 { section_posXML :: !XML.Pos
114 , section_attrs :: !CommonAttrs
115 , section_title :: !Title
116 , section_aliases :: ![Alias]
117 , section_judgments :: ![Judgment]
118 } deriving (Eq,Show)
119
120 -- * Type 'Block'
121 data Block
122 = BlockPara Para
123 | BlockBreak { attrs :: !CommonAttrs }
124 | BlockToC { posXML :: !XML.Pos
125 , attrs :: !CommonAttrs
126 , depth :: !(Maybe Nat)
127 }
128 | BlockToF { posXML :: !XML.Pos
129 , attrs :: !CommonAttrs
130 , types :: ![TL.Text]
131 }
132 | BlockAside { posXML :: !XML.Pos
133 , attrs :: !CommonAttrs
134 , blocks :: ![Block]
135 }
136 | BlockFigure { posXML :: !XML.Pos
137 , type_ :: !TL.Text
138 , attrs :: !CommonAttrs
139 , mayTitle :: !(Maybe Title)
140 , paras :: ![Para]
141 }
142 | BlockIndex { posXML :: !XML.Pos
143 , attrs :: !CommonAttrs
144 , terms :: !Terms
145 }
146 | BlockReferences { posXML :: !XML.Pos
147 , attrs :: !CommonAttrs
148 , refs :: ![Reference]
149 } -- FIXME: move to ParaReferences?
150 | BlockJudges !Judges
151 | BlockGrades { posXML :: !XML.Pos
152 , attrs :: !CommonAttrs
153 , scale :: ![Grade]
154 }
155 deriving (Eq,Show)
156
157 -- * Type 'Judgment'
158 data Judgment = Judgment
159 { judgment_opinionsByChoice :: !(Maybe (MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)))
160 , judgment_judges :: !(Maybe Judges)
161 , judgment_grades :: !(Maybe (MJ.Grades (MJ.Ranked Grade)))
162 , judgment_posXML :: !XML.Pos
163 , judgment_locTCT :: !TCT.Location
164 , judgment_judgesId :: !Ident
165 , judgment_gradesId :: !Ident
166 , judgment_importance :: !(Maybe MJ.Share)
167 , judgment_question :: !(Maybe Title)
168 , judgment_choices :: ![Choice]
169 } deriving (Show)
170 instance Eq Judgment where
171 x==y =
172 judgment_judgesId x == judgment_judgesId y &&
173 judgment_gradesId x == judgment_gradesId y &&
174 judgment_question x == judgment_question y
175 instance Hashable Judgment where
176 hashWithSalt s Judgment{..} =
177 s`hashWithSalt`judgment_judgesId
178 `hashWithSalt`judgment_gradesId
179 `hashWithSalt`judgment_question
180
181 -- ** Type 'ErrorJudgment'
182 data ErrorJudgment
183 = ErrorJudgment_Judges
184 | ErrorJudgment_Grades
185 deriving (Eq,Show)
186
187 -- ** Type 'Judges'
188 data Judges = Judges
189 { judges_locTCT :: !TCT.Location
190 , judges_posXML :: !XML.Pos
191 , judges_attrs :: !CommonAttrs
192 , judges_byName :: !(HM.HashMap Name [Judge])
193 } deriving (Eq,Show)
194
195 -- ** Type 'Judge'
196 data Judge = Judge
197 { judge_locTCT :: !TCT.Location
198 , judge_posXML :: !XML.Pos
199 , judge_name :: !Name
200 , judge_title :: !(Maybe Title)
201 , judge_defaultGrades :: !(HM.HashMap Ident [Name])
202 } deriving (Eq,Show)
203
204 -- ** Type 'Grade'
205 data Grade = Grade
206 { grade_posXML :: !XML.Pos
207 , grade_name :: !Name
208 , grade_color :: !TL.Text
209 , grade_isDefault :: !Bool
210 , grade_title :: !(Maybe Title)
211 } deriving (Eq,Show)
212
213 -- ** Type 'Choice'
214 data Choice = Choice
215 { choice_locTCT :: TCT.Location
216 , choice_posXML :: XML.Pos
217 , choice_title :: !(Maybe Title)
218 , choice_opinions :: ![Opinion]
219 } deriving (Show)
220 instance Eq Choice where
221 (==) = (==)`on`choice_title
222 instance Hashable Choice where
223 hashWithSalt s Choice{..} =
224 hashWithSalt s choice_title
225
226 -- ** Type 'Opinion'
227 data Opinion = Opinion
228 { opinion_locTCT :: !TCT.Location
229 , opinion_posXML :: !XML.Pos
230 , opinion_judge :: !Name
231 , opinion_grade :: !Name
232 , opinion_importance :: !(Maybe MJ.Share)
233 , opinion_comment :: !(Maybe Title)
234 } deriving (Eq,Show)
235
236 -- * Type 'Para'
237 data Para
238 = ParaItem { item :: !ParaItem }
239 | ParaItems { posXML :: !XML.Pos
240 , attrs :: !CommonAttrs
241 , items :: ![ParaItem]
242 }
243 deriving (Eq,Show)
244
245 -- ** Type 'ParaItem'
246 data ParaItem
247 = ParaPlain !Plain
248 | ParaComment !TL.Text
249 | ParaOL ![ListItem]
250 | ParaUL ![[Para]]
251 | ParaQuote { type_ :: !TL.Text
252 , paras :: ![Para]
253 }
254 | ParaArtwork { type_ :: !TL.Text
255 , text :: !TL.Text
256 }
257 | ParaJudgment !Judgment
258 deriving (Eq,Show)
259
260 -- *** Type 'ListItem'
261 data ListItem = ListItem
262 { name :: !Name
263 , paras :: ![Para]
264 } deriving (Eq,Show)
265
266 -- * Type 'Plain'
267 type Plain = TS.Trees PlainNode
268
269 -- ** Type 'PlainNode'
270 data PlainNode
271 -- Nodes
272 = PlainB -- ^ Bold
273 | PlainCode -- ^ Code (monospaced)
274 | PlainDel -- ^ Deleted (crossed-over)
275 | PlainI -- ^ Italic
276 | PlainGroup -- ^ Group subTrees (neutral)
277 | PlainQ -- ^ Quoted
278 | PlainSC -- ^ Small Caps
279 | PlainSub -- ^ Subscript
280 | PlainSup -- ^ Superscript
281 | PlainU -- ^ Underlined
282 | PlainEref { eref_href :: !URL } -- ^ External reference
283 | PlainIref { iref_term :: !Words
284 } -- ^ Index reference
285 | PlainTag { tag_locTCT :: !TCT.Location
286 , tag_posXML :: !XML.Pos
287 } -- ^ Reference
288 | PlainRref { rref_locTCT :: !TCT.Location
289 , rref_posXML :: !XML.Pos
290 , rref_to :: !Ident
291 } -- ^ Reference reference
292 | PlainSpan { attrs :: !CommonAttrs } -- ^ Neutral node
293 -- Leafs
294 | PlainBreak -- ^ Line break (\n)
295 | PlainText TL.Text
296 | PlainNote { note_paras :: ![Para]
297 } -- ^ Footnote
298 deriving (Eq,Show)
299
300 {-
301 -- * Type 'ErrorTarget'
302 data ErrorTarget
303 = ErrorTarget_Unknown !Nat1
304 | ErrorTarget_Ambiguous !(Maybe Nat1)
305 deriving (Eq,Show)
306
307 -- * Type 'ErrorAnchor'
308 data ErrorAnchor
309 = ErrorAnchor_Ambiguous !Nat1
310 deriving (Eq,Show)
311 -}
312
313 -- * Type 'CommonAttrs'
314 data CommonAttrs = CommonAttrs
315 { id :: !(Maybe Ident)
316 , classes :: ![TL.Text]
317 } deriving (Eq,Ord,Show)
318 instance Default CommonAttrs where
319 def = CommonAttrs
320 { id = def
321 , classes = def
322 }
323
324 -- ** Type 'Anchor'
325 data Anchor = Anchor
326 { anchor_section :: !XML.Pos
327 , anchor_count :: !Nat1
328 } deriving (Eq,Ord,Show)
329
330 -- * Type 'Name'
331 newtype Name = Name { unName :: TL.Text }
332 deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)
333
334 -- * Type 'Title'
335 newtype Title = Title { unTitle :: Plain }
336 deriving (Show,Semigroup,Monoid,Default)
337 instance Eq Title where
338 (==) = (==) `on` similarPlain . unTitle
339 -- | Return a similar version of a 'Plain' by removing:
340 --
341 -- * parsing residues ('PlainGroup'),
342 -- * notes ('PlainNote'),
343 -- * and position specific annotations ('Ident' and 'Anchor').
344 similarPlain :: Plain -> Plain
345 similarPlain = foldMap $ \(TS.Tree n ts) ->
346 let skip = similarPlain ts in
347 let keep = pure $ TS.Tree n $ skip in
348 case n of
349 PlainGroup -> skip
350 PlainNote{} -> skip
351 PlainIref{..} -> keep
352 PlainRref{..} -> pure $ TS.Tree PlainRref{ rref_locTCT = def
353 , .. } skip
354 PlainSpan attrs -> pure $ TS.Tree n' skip
355 where n' = PlainSpan{attrs = CommonAttrs{ id = Nothing
356 , classes = List.sort $ classes attrs }}
357 PlainB -> keep
358 PlainCode -> keep
359 PlainDel -> keep
360 PlainI -> keep
361 PlainQ -> keep
362 PlainSC -> keep
363 PlainSub -> keep
364 PlainSup -> keep
365 PlainU -> keep
366 PlainEref{..} -> keep
367 PlainTag{..} -> pure $ TS.Tree PlainTag{tag_locTCT=def, ..} skip
368 PlainBreak -> keep
369 PlainText{} -> keep
370 -- | Return the same hash if 'similarPlain' is applied on the 'Title' before hashing.
371 --
372 -- Warning: when using the key of HashMap or HashSet,
373 -- only the data taken into account by this 'Hashable' instance is reliable.
374 instance Hashable Title where
375 hashWithSalt salt (Title ps) = hs salt ps
376 where
377 hs = foldr h
378 h (TS.Tree n ts) s =
379 (`hs` ts) $
380 case n of
381 PlainGroup -> s
382 PlainNote{} -> s
383 PlainIref{..} -> s`hashWithSalt`(0::Int)`hashWithSalt`iref_term
384 PlainTag{..} -> s`hashWithSalt`(1::Int)
385 PlainSpan{..} -> s`hashWithSalt`(2::Int)`hashWithSalt`List.sort (classes attrs)
386 PlainB -> s`hashWithSalt`(3::Int)
387 PlainCode -> s`hashWithSalt`(4::Int)
388 PlainDel -> s`hashWithSalt`(5::Int)
389 PlainI -> s`hashWithSalt`(6::Int)
390 PlainQ -> s`hashWithSalt`(7::Int)
391 PlainSC -> s`hashWithSalt`(8::Int)
392 PlainSub -> s`hashWithSalt`(9::Int)
393 PlainSup -> s`hashWithSalt`(10::Int)
394 PlainU -> s`hashWithSalt`(11::Int)
395 PlainEref{..} -> s`hashWithSalt`(12::Int)`hashWithSalt`eref_href
396 PlainRref{..} -> s`hashWithSalt`(13::Int)`hashWithSalt`rref_to
397 PlainBreak -> s`hashWithSalt`(14::Int)
398 PlainText t -> s`hashWithSalt`(15::Int)`hashWithSalt`t
399
400 -- ** Type 'Entity'
401 data Entity = Entity
402 { entity_name :: !TL.Text
403 , entity_street :: !TL.Text
404 , entity_zipcode :: !TL.Text
405 , entity_city :: !TL.Text
406 , entity_region :: !TL.Text
407 , entity_country :: !TL.Text
408 , entity_email :: !TL.Text
409 , entity_tel :: !TL.Text
410 , entity_fax :: !TL.Text
411 , entity_url :: !(Maybe URL)
412 , entity_org :: !(Maybe Entity)
413 } deriving (Eq,Show)
414 instance Default Entity where
415 def = Entity
416 { entity_name = def
417 , entity_street = def
418 , entity_zipcode = def
419 , entity_city = def
420 , entity_region = def
421 , entity_country = def
422 , entity_email = def
423 , entity_tel = def
424 , entity_fax = def
425 , entity_url = def
426 , entity_org = def
427 }
428
429 -- * Type 'Include'
430 newtype Include = Include
431 { href :: FilePath
432 } deriving (Eq,Show)
433 instance Default Include where
434 def = Include
435 { href = def
436 }
437
438 -- * Type 'Reference'
439 data Reference = Reference
440 { {-reference_error :: !(Maybe ErrorAnchor)
441 ,-} reference_posXML :: !XML.Pos
442 , reference_locTCT :: !TCT.Location
443 , reference_id :: !Ident
444 , reference_about :: !About
445 } deriving (Eq,Show)
446
447 -- * Type 'Date'
448 data Date = Date
449 { year :: !Int
450 , month :: !(Maybe Nat1)
451 , day :: !(Maybe Nat1)
452 } deriving (Eq,Show)
453 instance Default Date where
454 def = Date
455 { year = 1970
456 , month = Just (Nat1 01)
457 , day = Just (Nat1 01)
458 }
459 instance Semigroup Date where
460 _x <> y = y
461
462 -- * Type 'Link'
463 data Link = Link
464 { name :: !Name
465 , href :: !URL
466 , rel :: !TL.Text
467 , type_ :: !(Maybe TL.Text)
468 , plain :: !Plain
469 } deriving (Eq,Show)
470 instance Default Link where
471 def = Link
472 { name = def
473 , href = def
474 , rel = def
475 , type_ = def
476 , plain = def
477 }
478
479 -- * Type 'Alias'
480 newtype Alias = Alias
481 { title :: Title
482 } deriving (Eq,Show)
483
484 -- * Type 'Serie'
485 data Serie = Serie
486 { name :: !Name
487 , id :: !TL.Text
488 } deriving (Eq,Show)
489 instance Default Serie where
490 def = Serie
491 { name = def
492 , id = def
493 }
494
495 -- | Builtins 'URL' recognized from |Serie|'s 'name'.
496 urlSerie :: Serie -> Maybe URL
497 urlSerie Serie{id=id_, name} =
498 case name of
499 "RFC" | TL.all Char.isDigit id_ ->
500 Just $ URL $ "https://tools.ietf.org/html/rfc"<>id_
501 "DOI" -> Just $ URL $ "https://dx.doi.org/"<>id_
502 _ -> Nothing
503
504 -- * Type 'Word'
505 type Word = TL.Text
506
507 -- ** Type 'Words'
508 type Words = [WordOrSpace]
509
510 -- *** Type 'WordOrSpace'
511 data WordOrSpace
512 = Word !Word
513 | Space
514 deriving (Eq,Ord,Show,Generic)
515 instance Hashable WordOrSpace
516
517 -- ** Type 'Terms'
518 type Terms = [Aliases]
519
520 -- *** Type 'Aliases'
521 type Aliases = [Words]
522
523 -- ** Type 'PathWord'
524 type PathWord = TM.Path Word
525
526 pathFromWords :: Words -> Maybe PathWord
527 pathFromWords ws =
528 case ws >>= unSpace of
529 p:ps | not (TL.null p) -> Just (TM.path p ps)
530 _ -> Nothing
531 where
532 unSpace = \case
533 Space -> []
534 Word w -> [w]
535
536 -- * Type 'Location'
537 type Location = (TCT.Location, XML.Pos)