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