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