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