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