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
 303  | PlainAref { aref_locTCT :: !TCT.Location
 304              , aref_posXML :: !XML.Pos
 305              , aref_ident  :: !Ident
 306              } -- ^ Ref
 307  deriving (Eq,Show)
 308
 309 {-
 310 -- * Type 'Tag'
 311 newtype Tag = Tag TL.Text
 312  deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)
 313 -}
 314
 315 {-
 316 -- * Type 'ErrorTarget'
 317 data ErrorTarget
 318  =   ErrorTarget_Unknown !Nat1
 319  |   ErrorTarget_Ambiguous !(Maybe Nat1)
 320  deriving (Eq,Show)
 321
 322 -- * Type 'ErrorAnchor'
 323 data ErrorAnchor
 324  =   ErrorAnchor_Ambiguous !Nat1
 325  deriving (Eq,Show)
 326 -}
 327
 328 -- * Type 'CommonAttrs'
 329 data CommonAttrs = CommonAttrs
 330  { attrs_id      :: !(Maybe Ident)
 331  , attrs_classes :: ![TL.Text]
 332  } deriving (Eq,Ord,Show)
 333 instance Default CommonAttrs where
 334         def = CommonAttrs
 335          { attrs_id      = def
 336          , attrs_classes = def
 337          }
 338
 339 -- ** Type 'Anchor'
 340 data Anchor = Anchor
 341  { anchor_section :: !XML.Pos
 342  , anchor_count   :: !Nat1
 343  } deriving (Eq,Ord,Show)
 344
 345 -- * Type 'Name'
 346 newtype Name = Name { unName :: TL.Text }
 347  deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)
 348
 349 -- * Type 'Title'
 350 newtype Title = Title { unTitle :: Plain }
 351  deriving (Show,Semigroup,Monoid,Default)
 352 instance Eq Title where
 353         (==) = (==) `on` similarPlain . unTitle
 354 -- | Return a similar version of a 'Plain' by removing:
 355 --
 356 -- * parsing residues ('PlainGroup'),
 357 -- * notes ('PlainNote'),
 358 -- * and position specific annotations ('Ident' and 'Anchor').
 359 similarPlain :: Plain -> Plain
 360 similarPlain = foldMap $ \(TS.Tree n ts) ->
 361         let skip = similarPlain ts in
 362         let keep = pure $ TS.Tree n $ skip in
 363         case n of
 364          PlainGroup       -> skip
 365          PlainNote{}      -> skip
 366          PlainIref{..}    -> keep
 367          PlainRef{..}     -> pure $ TS.Tree PlainRef{ ref_locTCT = def
 368                                                     , ref_posXML = def
 369                                                     , .. } skip
 370          PlainSpan attrs  -> pure $ TS.Tree n' skip
 371                              where n' = PlainSpan{attrs = CommonAttrs{ attrs_id      = Nothing
 372                                                                      , attrs_classes = List.sort $ attrs_classes attrs }}
 373          PlainB           -> keep
 374          PlainCode        -> keep
 375          PlainDel         -> keep
 376          PlainI           -> keep
 377          PlainQ           -> keep
 378          PlainSC          -> keep
 379          PlainSub         -> keep
 380          PlainSup         -> keep
 381          PlainU           -> keep
 382          PlainEref{..}    -> keep
 383          PlainAt{..}      -> pure $ TS.Tree PlainAt{at_locTCT=def, at_posXML=def, ..} skip
 384          PlainTag{..}     -> pure $ TS.Tree PlainTag{tag_locTCT=def, tag_posXML=def, ..} skip
 385          PlainBreak       -> keep
 386          PlainText{}      -> keep
 387 -- | Return the same hash if 'similarPlain' is applied on the 'Title' before hashing.
 388 --
 389 -- Warning: when using the key of HashMap or HashSet,
 390 -- only the data taken into account by this 'Hashable' instance is reliable.
 391 instance Hashable Title where
 392         hashWithSalt salt (Title ps) = hs salt ps
 393                 where
 394                 hs = foldr h
 395                 h (TS.Tree n ts) s =
 396                         (`hs` ts) $
 397                         case n of
 398                          PlainGroup    -> s
 399                          PlainNote{}   -> s
 400                          PlainIref{..} -> s`hashWithSalt`(0::Int)`hashWithSalt`iref_term
 401                          PlainTag{..}  -> s`hashWithSalt`(1::Int)`hashWithSalt`tag_ident`hashWithSalt`tag_back
 402                          PlainAt{..}   -> s`hashWithSalt`(2::Int)`hashWithSalt`at_ident`hashWithSalt`at_back
 403                          PlainSpan{..} -> s`hashWithSalt`(3::Int)`hashWithSalt`List.sort (attrs_classes attrs)
 404                          PlainB        -> s`hashWithSalt`(4::Int)
 405                          PlainCode     -> s`hashWithSalt`(5::Int)
 406                          PlainDel      -> s`hashWithSalt`(6::Int)
 407                          PlainI        -> s`hashWithSalt`(7::Int)
 408                          PlainQ        -> s`hashWithSalt`(8::Int)
 409                          PlainSC       -> s`hashWithSalt`(9::Int)
 410                          PlainSub      -> s`hashWithSalt`(10::Int)
 411                          PlainSup      -> s`hashWithSalt`(11::Int)
 412                          PlainU        -> s`hashWithSalt`(12::Int)
 413                          PlainEref{..} -> s`hashWithSalt`(13::Int)`hashWithSalt`eref_href
 414                          PlainRef{..}  -> s`hashWithSalt`(14::Int)`hashWithSalt`ref_ident
 415                          PlainBreak    -> s`hashWithSalt`(15::Int)
 416                          PlainText t   -> s`hashWithSalt`(16::Int)`hashWithSalt`t
 417
 418 -- ** Type 'Entity'
 419 data Entity = Entity
 420  { entity_name    :: !TL.Text
 421  , entity_street  :: !TL.Text
 422  , entity_zipcode :: !TL.Text
 423  , entity_city    :: !TL.Text
 424  , entity_region  :: !TL.Text
 425  , entity_country :: !TL.Text
 426  , entity_email   :: !TL.Text
 427  , entity_tel     :: !TL.Text
 428  , entity_fax     :: !TL.Text
 429  , entity_url     :: !(Maybe URL)
 430  , entity_org     :: !(Maybe Entity)
 431  } deriving (Eq,Show)
 432 instance Default Entity where
 433         def = Entity
 434          { entity_name    = def
 435          , entity_street  = def
 436          , entity_zipcode = def
 437          , entity_city    = def
 438          , entity_region  = def
 439          , entity_country = def
 440          , entity_email   = def
 441          , entity_tel     = def
 442          , entity_fax     = def
 443          , entity_url     = def
 444          , entity_org     = def
 445          }
 446
 447 -- * Type 'Include'
 448 newtype Include = Include
 449  { href :: FilePath
 450  } deriving (Eq,Show)
 451 instance Default Include where
 452         def = Include
 453          { href = def
 454          }
 455
 456 -- * Type 'Reference'
 457 data Reference = Reference
 458  { {-reference_error  :: !(Maybe ErrorAnchor)
 459  ,-} reference_posXML :: !XML.Pos
 460  , reference_locTCT :: !TCT.Location
 461  , reference_id     :: !Ident
 462  , reference_about  :: !About
 463  } deriving (Eq,Show)
 464
 465 -- * Type 'Date'
 466 data Date = Date
 467  { year  :: !Int
 468  , month :: !(Maybe Nat1)
 469  , day   :: !(Maybe Nat1)
 470  } deriving (Eq,Show)
 471 instance Default Date where
 472         def = Date
 473          { year  = 1970
 474          , month = Just (Nat1 01)
 475          , day   = Just (Nat1 01)
 476          }
 477 instance Semigroup Date where
 478         _x <> y = y
 479
 480 -- * Type 'Link'
 481 data Link = Link
 482  { name  :: !Name
 483  , href  :: !URL
 484  , rel   :: !TL.Text
 485  , type_ :: !(Maybe TL.Text)
 486  , plain :: !Plain
 487  } deriving (Eq,Show)
 488 instance Default Link where
 489         def = Link
 490          { name  = def
 491          , href  = def
 492          , rel   = def
 493          , type_ = def
 494          , plain = def
 495          }
 496
 497 -- * Type 'Alias'
 498 data Alias = Alias
 499  { alias_attrs :: !CommonAttrs
 500  , alias_title :: !Title
 501  } deriving (Eq,Show)
 502
 503 -- * Type 'Serie'
 504 data Serie = Serie
 505  { serie_name :: !Name
 506  , serie_id   :: !TL.Text
 507  } deriving (Eq,Show)
 508 instance Default Serie where
 509         def = Serie
 510          { serie_name = def
 511          , serie_id   = def
 512          }
 513
 514 -- | Builtins 'URL' recognized from |Serie|'s 'name'.
 515 urlSerie :: Serie -> Maybe URL
 516 urlSerie Serie{..} =
 517         case serie_name of
 518          "RFC" | TL.all Char.isDigit serie_id ->
 519                 Just $ URL $ "https://tools.ietf.org/html/rfc"<>serie_id
 520          "DOI" -> Just $ URL $ "https://dx.doi.org/"<>serie_id
 521          _ -> Nothing
 522
 523 -- * Type 'Word'
 524 type Word = TL.Text
 525
 526 -- ** Type 'Words'
 527 type Words = [WordOrSpace]
 528
 529 -- *** Type 'WordOrSpace'
 530 data WordOrSpace
 531  = Word !Word
 532  | Space
 533  deriving (Eq,Ord,Show,Generic)
 534 instance Hashable WordOrSpace
 535
 536 -- ** Type 'Terms'
 537 type Terms = [Aliases]
 538
 539 -- *** Type 'Aliases'
 540 type Aliases = [Words]
 541
 542 -- ** Type 'PathWord'
 543 type PathWord = TM.Path Word
 544
 545 pathFromWords :: Words -> Maybe PathWord
 546 pathFromWords ws =
 547         case ws >>= unSpace of
 548          p:ps | not (TL.null p) -> Just (TM.path p ps)
 549          _ -> Nothing
 550         where
 551         unSpace = \case
 552          Space  -> []
 553          Word w -> [w]
 554
 555 -- * Type 'Location'
 556 type Location = (TCT.Location, XML.Pos)