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  { 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