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