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