src/Textphile/DTC/Document.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2 {-# LANGUAGE DisambiguateRecordFields #-}
   3 {-# LANGUAGE DuplicateRecordFields #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 module Textphile.DTC.Document
   8  ( module Textphile.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.TreeMap.Strict as TM
  38 import qualified Data.TreeSeq.Strict as TS
  39 import qualified Majority.Judgment as MJ
  40
  41 import Textphile.Utils (Nat(..), Nat1(..), succNat, succNat1)
  42 import Textphile.XML (Ident(..), URL(..))
  43 import qualified Textphile.XML as XML
  44 import qualified Textphile.TCT.Cell as TCT
  45
  46 -- * Type 'Document'
  47 data Document = Document
  48  { document_head :: !(Maybe Head)
  49  , document_body :: !Body
  50  } deriving (Eq,Show)
  51
  52 -- * Type 'Head'
  53 data Head = Head
  54  { head_section :: !Section
  55  , head_body    :: !Body
  56  } deriving (Eq,Show)
  57 instance Default Head where
  58         def = Head
  59          { head_section = def
  60          , head_body    = def
  61          }
  62 instance Ord Head where
  63         compare = compare `on` head_section
  64
  65 {-
  66 -- * Type 'Header'
  67 data Header = Header
  68  { header_name  :: !TL.Text
  69  , header_value :: !Plain
  70  } deriving (Eq,Show)
  71 -}
  72
  73 -- * Type 'Body'
  74 type Body = TS.Trees BodyNode
  75
  76 -- ** Type 'BodyNode'
  77 data BodyNode
  78  = BodySection !Section -- ^ node
  79  | BodyBlock   !Block   -- ^ leaf
  80  deriving (Eq,Show)
  81
  82 -- Type 'Section'
  83 data Section = Section
  84  { section_posXML :: !XML.Pos
  85  , section_locTCT :: !TCT.Location
  86  , section_attrs  :: !CommonAttrs
  87  , section_about  :: !About
  88  } deriving (Eq,Show)
  89 instance Ord Section where
  90         compare = compare `on` section_posXML
  91 instance Default Section where
  92         def = Section
  93          { section_posXML = def
  94          , section_locTCT = def
  95          , section_attrs  = def
  96          , section_about  = def
  97          }
  98
  99 -- * Type 'About'
 100 data About = About
 101  { about_titles      :: ![Title]
 102  , about_aliases     :: ![Alias]
 103  , about_authors     :: ![Entity]
 104  , about_dates       :: ![Date]
 105  , about_tags        :: ![TL.Text]
 106  , about_links       :: ![Link]
 107  , about_series      :: ![Serie]
 108  , about_description :: ![Para]
 109  , about_judgments   :: ![Judgment]
 110  } deriving (Eq,Show)
 111 instance Default About where
 112         def = About
 113          { about_titles      = def
 114          , about_aliases     = def
 115          , about_dates       = def
 116          , about_authors     = def
 117          , about_tags        = def
 118          , about_links       = def
 119          , about_series      = def
 120          , about_description = def
 121          , about_judgments   = def
 122          }
 123 instance Semigroup About where
 124         x <> y = About
 125          { about_titles      = about_titles      x <> about_titles      y
 126          , about_aliases     = about_aliases     x <> about_aliases     y
 127          , about_dates       = about_dates       x <> about_dates       y
 128          , about_authors     = about_authors     x <> about_authors     y
 129          , about_tags        = about_tags        x <> about_tags        y
 130          , about_links       = about_links       x <> about_links       y
 131          , about_series      = about_series      x <> about_series      y
 132          , about_description = about_description x <> about_description y
 133          , about_judgments   = about_judgments   x <> about_judgments   y
 134          }
 135 instance Monoid About where
 136         mempty  = def
 137         mappend = (<>)
 138
 139 -- * Type 'Block'
 140 data Block
 141  = BlockPara       Para
 142  | BlockBreak      { attrs    :: !CommonAttrs }
 143  | BlockToC        { posXML   :: !XML.Pos
 144                    , attrs    :: !CommonAttrs
 145                    , depth    :: !(Maybe Nat)
 146                    }
 147  | BlockToF        { posXML   :: !XML.Pos
 148                    , attrs    :: !CommonAttrs
 149                    , types    :: ![TL.Text]
 150                    }
 151  | BlockAside      { posXML   :: !XML.Pos
 152                    , attrs    :: !CommonAttrs
 153                    , blocks   :: ![Block]
 154                    }
 155  | BlockFigure     { posXML   :: !XML.Pos
 156                    , type_    :: !TL.Text
 157                    , attrs    :: !CommonAttrs
 158                    , mayTitle :: !(Maybe Title)
 159                    , paras    :: ![Para]
 160                    }
 161  | BlockIndex      { posXML   :: !XML.Pos
 162                    , attrs    :: !CommonAttrs
 163                    , index    :: !Terms
 164                    }
 165  | BlockReferences { posXML   :: !XML.Pos
 166                    , attrs    :: !CommonAttrs
 167                    , refs     :: ![Reference]
 168                    } -- FIXME: move to ParaReferences?
 169  | BlockJudges     !Judges
 170  | BlockGrades     { posXML   :: !XML.Pos
 171                    , attrs    :: !CommonAttrs
 172                    , scale    :: ![Grade]
 173                    }
 174  deriving (Eq,Show)
 175
 176 -- * Type 'Index'
 177 type Index = TM.TreeMap Word Pos
 178
 179 -- * Type 'Judgment'
 180 data Judgment = Judgment
 181  { judgment_opinionsByChoice :: !(Maybe (MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)))
 182  -- , judgment_judges           :: !(Maybe Judges)
 183  -- , judgment_grades           :: !(Maybe (MJ.Grades (MJ.Ranked Grade)))
 184  , judgment_posXML           :: !XML.Pos
 185  , judgment_locTCT           :: !TCT.Location
 186  , judgment_judgesId         :: !Ident
 187  , judgment_gradesId         :: !Ident
 188  , judgment_importance       :: !(Maybe MJ.Share)
 189  , judgment_hide             :: !(Maybe Bool)
 190  , judgment_question         :: !(Maybe Title)
 191  , judgment_choices          :: ![Choice]
 192  } deriving (Eq,Show)
 193 instance Default Judgment where
 194         def = Judgment
 195          { judgment_opinionsByChoice = def
 196          -- , judgment_judges           = def
 197          -- , judgment_grades           = def
 198          , judgment_posXML           = def
 199          , judgment_locTCT           = def
 200          , judgment_judgesId         = def
 201          , judgment_gradesId         = def
 202          , judgment_importance       = def
 203          , judgment_hide             = def
 204          , judgment_question         = def
 205          , judgment_choices          = def
 206          }
 207
 208 -- ** Type 'JudgmentKey'
 209 data JudgmentKey = JudgmentKey
 210  { judgmentKey_judgesId :: !Ident
 211  , judgmentKey_gradesId :: !Ident
 212  , judgmentKey_question :: !(Maybe Title)
 213  } deriving (Eq,Show,Generic)
 214 instance Hashable JudgmentKey
 215
 216 -- ** Type 'ErrorJudgment'
 217 data ErrorJudgment
 218  =   ErrorJudgment_Judges
 219  |   ErrorJudgment_Grades
 220  deriving (Eq,Show)
 221
 222 -- ** Type 'Judges'
 223 data Judges = Judges
 224  { judges_locTCT :: !TCT.Location
 225  , judges_posXML :: !XML.Pos
 226  , judges_attrs  :: !CommonAttrs
 227  , judges_byName :: !(HM.HashMap Name [Judge])
 228  } deriving (Eq,Show)
 229
 230 -- ** Type 'Judge'
 231 data Judge = Judge
 232  { judge_locTCT        :: !TCT.Location
 233  , judge_posXML        :: !XML.Pos
 234  , judge_name          :: !Name
 235  , judge_title         :: !(Maybe Title)
 236  , judge_defaultGrades :: !(HM.HashMap Ident [Name])
 237  } deriving (Eq,Show)
 238
 239 -- ** Type 'Grade'
 240 data Grade = Grade
 241  { grade_posXML    :: !XML.Pos
 242  , grade_name      :: !Name
 243  , grade_color     :: !TL.Text
 244  , grade_isDefault :: !Bool
 245  , grade_title     :: !(Maybe Title)
 246  } deriving (Eq,Show)
 247
 248 -- ** Type 'Choice'
 249 data Choice = Choice
 250  { choice_locTCT   :: TCT.Location
 251  , choice_posXML   :: XML.Pos
 252  , choice_title    :: !(Maybe Title)
 253  , choice_opinions :: ![Opinion]
 254  } deriving (Show)
 255 instance Eq Choice where
 256         (==) = (==)`on`choice_title
 257 instance Hashable Choice where
 258         hashWithSalt s Choice{..} =
 259                 hashWithSalt s choice_title
 260
 261 -- ** Type 'Opinion'
 262 data Opinion = Opinion
 263  { opinion_locTCT     :: !TCT.Location
 264  , opinion_posXML     :: !XML.Pos
 265  , opinion_judge      :: !Name
 266  , opinion_grade      :: !Name
 267  , opinion_default    :: !(Maybe Name)
 268  , opinion_importance :: !(Maybe MJ.Share)
 269  , opinion_comment    :: !(Maybe Title)
 270  } deriving (Eq,Show)
 271
 272 -- * Type 'Para'
 273 data Para
 274  = ParaItem  { item   :: !ParaItem }
 275  | ParaItems { posXML :: !XML.Pos
 276              , attrs  :: !CommonAttrs
 277              , items  :: ![ParaItem]
 278              }
 279  deriving (Eq,Show)
 280
 281 -- ** Type 'ParaItem'
 282 data ParaItem
 283  = ParaPlain    !Plain
 284  | ParaComment  !TL.Text
 285  | ParaOL       ![ListItem]
 286  | ParaUL       ![[Para]]
 287  | ParaQuote    { type_  :: !TL.Text
 288                 , paras  :: ![Para]
 289                 }
 290  | ParaArtwork  { type_  :: !TL.Text
 291                 , text   :: !TL.Text
 292                 }
 293  | ParaJudgment !Judgment
 294  deriving (Eq,Show)
 295
 296 -- *** Type 'ListItem'
 297 data ListItem = ListItem
 298  { name  :: !Name
 299  , paras :: ![Para]
 300  } deriving (Eq,Show)
 301
 302 -- * Type 'Plain'
 303 type Plain = TS.Trees PlainNode
 304
 305 -- ** Type 'PlainNode'
 306 data PlainNode
 307  -- Nodes
 308  = PlainB     -- ^ Bold
 309  | PlainCode  -- ^ Code (monospaced)
 310  | PlainDel   -- ^ Deleted (crossed-over)
 311  | PlainI     -- ^ Italic
 312  | PlainGroup -- ^ Group subTrees (neutral)
 313  | PlainQ     -- ^ Quoted
 314  | PlainSC    -- ^ Small Caps
 315  | PlainSub   -- ^ Subscript
 316  | PlainSup   -- ^ Superscript
 317  | PlainU     -- ^ Underlined
 318  | PlainEref { eref_href :: !URL } -- ^ External reference
 319  | PlainIref { iref_term :: !Words
 320              } -- ^ Index reference
 321  | PlainRef  { ref_locTCT :: !TCT.Location
 322              , ref_posXML :: !XML.Pos
 323              , ref_ident  :: !Ident
 324              } -- ^ Reference reference
 325  | PlainPageRef  { pageRef_locTCT :: !TCT.Location
 326                  , pageRef_posXML :: !XML.Pos
 327                  , pageRef_path   :: !PathPage
 328                  , pageRef_at     :: !(Maybe Ident)
 329                  } -- ^ Page reference
 330  | PlainSpan { attrs :: !CommonAttrs } -- ^ Neutral node
 331  -- Leafs
 332  | PlainBreak -- ^ Line break (\n)
 333  | PlainText TL.Text
 334  | PlainNote { note_paras :: ![Para]
 335              } -- ^ Footnote
 336  | PlainTag  { tag_locTCT :: !TCT.Location
 337              , tag_posXML :: !XML.Pos
 338              , tag_ident  :: !Ident
 339              , tag_back   :: !Bool
 340              }
 341  | PlainAt   { at_locTCT :: !TCT.Location
 342              , at_posXML :: !XML.Pos
 343              , at_ident  :: !Ident
 344              , at_back   :: !Bool
 345              }
 346  deriving (Eq,Show)
 347
 348 {-
 349 -- * Type 'To'
 350 data To
 351  = To_At !Ident
 352  | To_Tag  !Ident
 353  deriving (Eq,Show)
 354
 355 -- * Type 'Tag'
 356 newtype Tag = Tag TL.Text
 357  deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)
 358 -}
 359
 360 {-
 361 -- * Type 'ErrorTarget'
 362 data ErrorTarget
 363  =   ErrorTarget_Unknown !Nat1
 364  |   ErrorTarget_Ambiguous !(Maybe Nat1)
 365  deriving (Eq,Show)
 366
 367 -- * Type 'ErrorAnchor'
 368 data ErrorAnchor
 369  =   ErrorAnchor_Ambiguous !Nat1
 370  deriving (Eq,Show)
 371 -}
 372
 373 -- * Type 'CommonAttrs'
 374 data CommonAttrs = CommonAttrs
 375  { attrs_id      :: !(Maybe Ident)
 376  , attrs_classes :: ![TL.Text]
 377  } deriving (Eq,Ord,Show)
 378 instance Default CommonAttrs where
 379         def = CommonAttrs
 380          { attrs_id      = def
 381          , attrs_classes = def
 382          }
 383
 384 -- ** Type 'Anchor'
 385 data Anchor = Anchor
 386  { anchor_section :: !XML.Pos
 387  , anchor_count   :: !Nat1
 388  } deriving (Eq,Ord,Show)
 389
 390 -- * Type 'PathPage'
 391 type PathPage = TL.Text
 392
 393 -- * Type 'Name'
 394 newtype Name = Name { unName :: TL.Text }
 395  deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)
 396
 397 -- * Type 'Title'
 398 newtype Title = Title { unTitle :: Plain }
 399  deriving (Show,Semigroup,Monoid,Default)
 400 instance Eq Title where
 401         (==) = (==) `on` similarPlain . unTitle
 402 -- | Return a similar version of a 'Plain' by removing:
 403 --
 404 -- * parsing residues ('PlainGroup'),
 405 -- * notes ('PlainNote'),
 406 -- * and position specific annotations ('Ident' and 'Anchor').
 407 similarPlain :: Plain -> Plain
 408 similarPlain = foldMap $ \(TS.Tree n ts) ->
 409         let skip = similarPlain ts in
 410         let keep = pure $ TS.Tree n $ skip in
 411         case n of
 412          PlainGroup       -> skip
 413          PlainNote{}      -> skip
 414          PlainIref{..}    -> keep
 415          PlainRef{..}     -> pure $ TS.Tree PlainRef{ ref_locTCT = def
 416                                                     , ref_posXML = def
 417                                                     , .. } skip
 418          PlainPageRef{..} -> pure $ TS.Tree PlainPageRef{ pageRef_locTCT = def
 419                                                         , pageRef_posXML = def
 420                                                         , .. } skip
 421          PlainSpan attrs  -> pure $ TS.Tree n' skip
 422                              where n' = PlainSpan{attrs = CommonAttrs{ attrs_id      = Nothing
 423                                                                      , attrs_classes = List.sort $ attrs_classes attrs }}
 424          PlainB           -> keep
 425          PlainCode        -> keep
 426          PlainDel         -> keep
 427          PlainI           -> keep
 428          PlainQ           -> keep
 429          PlainSC          -> keep
 430          PlainSub         -> keep
 431          PlainSup         -> keep
 432          PlainU           -> keep
 433          PlainEref{..}    -> keep
 434          PlainAt{..}      -> pure $ TS.Tree PlainAt{at_locTCT=def, at_posXML=def, ..} skip
 435          PlainTag{..}     -> pure $ TS.Tree PlainTag{tag_locTCT=def, tag_posXML=def, ..} skip
 436          PlainBreak       -> keep
 437          PlainText{}      -> keep
 438 -- | Return the same hash if 'similarPlain' is applied on the 'Title' before hashing.
 439 --
 440 -- Warning: when using the key of HashMap or HashSet,
 441 -- only the data taken into account by this 'Hashable' instance is reliable.
 442 instance Hashable Title where
 443         hashWithSalt salt (Title ps) = hs salt ps
 444                 where
 445                 hs = foldr h
 446                 h (TS.Tree n ts) s =
 447                         (`hs` ts) $
 448                         case n of
 449                          PlainGroup        -> s
 450                          PlainNote{}       -> s
 451                          PlainIref{..}     -> s`hashWithSalt`(0::Int)`hashWithSalt`iref_term
 452                          PlainTag{..}      -> s`hashWithSalt`(1::Int)`hashWithSalt`tag_ident`hashWithSalt`tag_back
 453                          PlainAt{..}       -> s`hashWithSalt`(2::Int)`hashWithSalt`at_ident`hashWithSalt`at_back
 454                          PlainSpan{..}     -> s`hashWithSalt`(3::Int)`hashWithSalt`List.sort (attrs_classes attrs)
 455                          PlainB            -> s`hashWithSalt`(4::Int)
 456                          PlainCode         -> s`hashWithSalt`(5::Int)
 457                          PlainDel          -> s`hashWithSalt`(6::Int)
 458                          PlainI            -> s`hashWithSalt`(7::Int)
 459                          PlainQ            -> s`hashWithSalt`(8::Int)
 460                          PlainSC           -> s`hashWithSalt`(9::Int)
 461                          PlainSub          -> s`hashWithSalt`(10::Int)
 462                          PlainSup          -> s`hashWithSalt`(11::Int)
 463                          PlainU            -> s`hashWithSalt`(12::Int)
 464                          PlainEref{..}     -> s`hashWithSalt`(13::Int)`hashWithSalt`eref_href
 465                          PlainRef{..}      -> s`hashWithSalt`(14::Int)`hashWithSalt`ref_ident
 466                          PlainPageRef{..}  -> s`hashWithSalt`(15::Int)`hashWithSalt`pageRef_at`hashWithSalt`pageRef_path
 467                          PlainBreak        -> s`hashWithSalt`(16::Int)
 468                          PlainText t       -> s`hashWithSalt`(17::Int)`hashWithSalt`t
 469
 470 -- * Type 'Entity'
 471 data Entity = Entity
 472  { entity_rel     :: !Name
 473  , entity_role    :: !Name
 474  , entity_name    :: !TL.Text
 475  , entity_street  :: !TL.Text
 476  , entity_zipcode :: !TL.Text
 477  , entity_city    :: !TL.Text
 478  , entity_region  :: !TL.Text
 479  , entity_country :: !TL.Text
 480  , entity_email   :: !TL.Text
 481  , entity_tel     :: !TL.Text
 482  , entity_fax     :: !TL.Text
 483  , entity_url     :: !(Maybe URL)
 484  , entity_org     :: ![Entity]
 485  } deriving (Eq,Show)
 486 instance Default Entity where
 487         def = Entity
 488          { entity_rel     = def
 489          , entity_role    = def
 490          , entity_name    = def
 491          , entity_street  = def
 492          , entity_zipcode = def
 493          , entity_city    = def
 494          , entity_region  = def
 495          , entity_country = def
 496          , entity_email   = def
 497          , entity_tel     = def
 498          , entity_fax     = def
 499          , entity_url     = def
 500          , entity_org     = def
 501          }
 502
 503 -- * Type 'Include'
 504 newtype Include = Include
 505  { include_href :: FilePath
 506  } deriving (Eq,Show)
 507 instance Default Include where
 508         def = Include
 509          { include_href = def
 510          }
 511
 512 -- * Type 'Reference'
 513 data Reference = Reference
 514  { reference_posXML :: !XML.Pos
 515  , reference_locTCT :: !TCT.Location
 516  , reference_id     :: !Ident
 517  , reference_about  :: !About
 518  } deriving (Eq,Show)
 519
 520 -- * Type 'Date'
 521 data Date = Date
 522  { date_rel   :: !Name
 523  , date_role  :: !Name
 524  , date_year  :: !Int
 525  , date_month :: !(Maybe Nat1)
 526  , date_day   :: !(Maybe Nat1)
 527  } deriving (Eq,Show)
 528 instance Default Date where
 529         def = Date
 530          { date_rel   = def
 531          , date_role  = def
 532          , date_year  = 1970
 533          , date_month = Just (Nat1 01)
 534          , date_day   = Just (Nat1 01)
 535          }
 536 instance Semigroup Date where
 537         _x <> y = y
 538
 539 -- * Type 'Link'
 540 data Link = Link
 541  { link_rel   :: !Name
 542  , link_role  :: !Name
 543  , link_url   :: !URL
 544  , link_plain :: !Plain
 545  -- , link_type  :: !(Maybe TL.Text)
 546  } deriving (Eq,Show)
 547 instance Default Link where
 548         def = Link
 549          { link_rel   = def
 550          , link_role  = def
 551          , link_url   = def
 552          , link_plain = def
 553          -- , link_type  = def
 554          }
 555
 556 -- * Type 'Alias'
 557 data Alias = Alias
 558  { alias_attrs :: !CommonAttrs
 559  , alias_title :: !Title
 560  } deriving (Eq,Show)
 561
 562 -- * Type 'Serie'
 563 data Serie = Serie
 564  { serie_name :: !Name
 565  , serie_id   :: !TL.Text
 566  } deriving (Eq,Show)
 567 instance Default Serie where
 568         def = Serie
 569          { serie_name = def
 570          , serie_id   = def
 571          }
 572
 573 -- | Builtins 'URL' recognized from |Serie|'s 'name'.
 574 urlSerie :: Serie -> Maybe URL
 575 urlSerie Serie{..} =
 576         case serie_name of
 577          "RFC" | TL.all Char.isDigit serie_id ->
 578                 Just $ URL $ "https://tools.ietf.org/html/rfc"<>serie_id
 579          "DOI" -> Just $ URL $ "https://dx.doi.org/"<>serie_id
 580          _ -> Nothing
 581
 582 -- * Type 'Word'
 583 type Word = TL.Text
 584
 585 -- ** Type 'Words'
 586 type Words = [WordOrSpace]
 587
 588 -- *** Type 'WordOrSpace'
 589 data WordOrSpace
 590  = Word !Word
 591  | Space
 592  deriving (Eq,Ord,Show,Generic)
 593 instance Hashable WordOrSpace
 594
 595 -- ** Type 'Terms'
 596 type Terms = [Aliases]
 597
 598 -- *** Type 'Aliases'
 599 type Aliases = [Words]
 600
 601 -- ** Type 'PathWord'
 602 type PathWord = TM.Path Word
 603
 604 pathFromWords :: Words -> Maybe PathWord
 605 pathFromWords ws =
 606         case ws >>= unSpace of
 607          p:ps | not (TL.null p) -> Just (TM.path p ps)
 608          _ -> Nothing
 609         where
 610         unSpace = \case
 611          Space  -> []
 612          Word w -> [w]
 613
 614 -- * Type 'Location'
 615 type Location = (TCT.Location, XML.Pos)
 616
 617 -- * Type 'Pos'
 618 type Pos = Seq Section