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