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