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