Hdoc/DTC/Sym.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 module Hdoc.DTC.Sym where
   5
   6 import Control.Applicative (Applicative(..), (<$>), (<$))
   7 import Control.Arrow (second)
   8 import Control.Monad (void)
   9 import Data.Bool (Bool(..))
  10 import Data.Default.Class (Default(..))
  11 import Data.Foldable (concat)
  12 import Data.Function (($), (.), flip)
  13 import Data.Maybe (Maybe(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.TreeSeq.Strict (Tree(..), tree0)
  16 import qualified Data.HashMap.Strict as HM
  17 import qualified Data.Sequence as Seq
  18 import qualified Data.Text.Lazy as TL
  19
  20 import Hdoc.XML
  21 import Hdoc.RNC.Sym as RNC
  22 import qualified Hdoc.DTC.Analyze.Index as Index
  23 import qualified Hdoc.DTC.Document as DTC
  24 import qualified Hdoc.RNC.Write as RNC
  25 import qualified Hdoc.TCT.Cell as TCT
  26 import qualified Hdoc.XML as XML
  27
  28 -- Class 'Sym_DTC'
  29 -- | Use a symantic (tagless final) class to encode
  30 -- both the parsing and the schema of DTC,
  31 -- when repr is respectively instanciated
  32 -- on 'DTC.Parser' or 'RNC.RuleWriter'.
  33 class RNC.Sym_RNC repr => Sym_DTC repr where
  34         positionXML      :: repr XML.Pos
  35         locationTCT      :: repr TCT.Location
  36         document         :: repr DTC.Document
  37
  38         head             :: repr DTC.Head
  39         about            :: repr DTC.About
  40         header           :: repr DTC.Header
  41
  42         body             :: repr DTC.Body
  43         include          :: repr DTC.Include
  44
  45         block            :: repr DTC.Block
  46         blockBreak       :: repr DTC.Block
  47         blockToC         :: repr DTC.Block
  48         blockToF         :: repr DTC.Block
  49         blockIndex       :: repr DTC.Block
  50         blockAside       :: repr DTC.Block
  51         blockFigure      :: repr DTC.Block
  52         blockReferences  :: repr DTC.Block
  53         blockJudges      :: repr DTC.Block
  54         blockGrades      :: repr DTC.Block
  55         reference        :: repr DTC.Reference
  56
  57         para             :: repr DTC.Para
  58         paraItem         :: repr DTC.ParaItem
  59         paraItems        :: repr DTC.Para
  60
  61         plain            :: repr DTC.Plain
  62         plainNode        :: repr (Tree DTC.PlainNode)
  63
  64         commonAttrs      :: repr DTC.CommonAttrs
  65         ident            :: repr Ident
  66         title            :: repr DTC.Title
  67         name             :: repr DTC.Name
  68         url              :: repr URL
  69         path             :: repr DTC.FilePath
  70         to               :: repr Ident
  71         id               :: repr Ident
  72         class_           :: repr [TL.Text]
  73
  74         author           :: repr DTC.Entity
  75         editor           :: repr DTC.Entity
  76         date             :: repr DTC.Date
  77         entity           :: repr DTC.Entity
  78         link             :: repr DTC.Link
  79         serie            :: repr DTC.Serie
  80         alias            :: repr DTC.Alias
  81         judgment         :: repr DTC.Judgment
  82         choice_          :: repr DTC.Choice
  83         opinion          :: repr DTC.Opinion
  84         judges           :: repr DTC.Judges
  85         judge            :: repr DTC.Judge
  86         grade            :: repr DTC.Grade
  87
  88         document = rule "document" $
  89                 DTC.Document
  90                  <$> head
  91                  <*> body
  92         head = rule "head" $
  93                 interleaved $
  94                 DTC.Head
  95                  <$?> (def, rule "about" $ element "about" about)
  96                  <|*> judgment
  97         body =
  98                 rule "body" $
  99                 (Seq.fromList <$>) $
 100                 many $
 101                         choice
 102                          [ element "section" $ Tree . DTC.BodySection <$> section <*> body
 103                          , tree0 . DTC.BodyBlock <$> block
 104                          ]
 105                 where
 106                 section =
 107                         DTC.Section
 108                          <$> positionXML
 109                          <*> commonAttrs
 110                          <*> title
 111                          <*> many alias
 112                          <*> many judgment
 113         title = rule "title" $ DTC.Title <$> element "title" plain
 114         name  = rule "name"  $ DTC.Name <$> text
 115         url   = rule "url"   $ URL <$> text
 116         path  = rule "path"  $ TL.unpack <$> text
 117         ident = rule "ident" $ Ident <$> text
 118         to    = rule "to"    $ attribute "to" ident
 119         commonAttrs =
 120                 rule "commonAttrs" $
 121                 interleaved $
 122                 DTC.CommonAttrs
 123                  <$?> (def, Just <$> id)
 124                  <|?> (def, class_)
 125         id     = rule "id"    $ attribute "id" ident
 126         class_ = rule "class" $ attribute "class" $ TL.words <$> text
 127         date = rule "date"  $
 128                 element "date" $
 129                 interleaved $
 130                 DTC.Date
 131                  <$?> (0, attribute "year" int)
 132                  <|?> (Nothing, Just <$> attribute "month" nat1)
 133                  <|?> (Nothing, Just <$> attribute "day"   nat1)
 134         include =
 135                 rule "include"  $
 136                 element "include" $
 137                 interleaved $
 138                 DTC.Include
 139                  <$?> (def, attribute "href" path)
 140         block = rule "block" $
 141                 choice
 142                  [ DTC.BlockPara <$> para
 143                  , blockBreak
 144                  , blockToC
 145                  , blockToF
 146                  , blockIndex
 147                  , blockAside
 148                  , blockFigure
 149                  , blockReferences
 150                  , blockJudges
 151                  , blockGrades
 152                  {-
 153                  , anyElem $ \n@XmlName{..} ->
 154                                 case xmlNameSpace of
 155                                  "" -> figure n
 156                  -}
 157                  ]
 158         blockBreak = rule "break" $
 159                 element "break" $
 160                 DTC.BlockBreak
 161                  <$> commonAttrs
 162         blockToC =
 163                 rule "blockToC" $
 164                 element "toc" $
 165                 DTC.BlockToC
 166                  <$> positionXML
 167                  <*> commonAttrs
 168                  <*> optional (attribute "depth" nat)
 169         blockToF =
 170                 rule "blockToF" $
 171                 element "tof" $
 172                 DTC.BlockToF
 173                  <$> positionXML
 174                  <*> commonAttrs
 175                  <*> option [] (
 176                         element "ul" $
 177                                 many $
 178                                         element "li" $
 179                                                 element "para" text)
 180         blockIndex =
 181                 rule "blockIndex" $
 182                 element "index" $
 183                 DTC.BlockIndex
 184                  <$> positionXML
 185                  <*> commonAttrs
 186                  <*> option [] (
 187                         element "ul" $
 188                                 many $
 189                                         element "li" $
 190                                                 element "para" $
 191                                                         (concat <$>) $
 192                                                         many $
 193                                                                 (Index.wordify <$>) . TL.lines <$> text)
 194         blockAside =
 195                 rule "blockAside" $
 196                 element "aside" $
 197                 DTC.BlockAside
 198                  <$> positionXML
 199                  <*> commonAttrs
 200                  <*> many block
 201         blockFigure =
 202                 rule "blockFigure" $
 203                 element "figure" $
 204                 DTC.BlockFigure
 205                  <$> positionXML
 206                  <*> attribute "type" text
 207                  <*> commonAttrs
 208                  <*> optional title
 209                  <*> many para
 210         blockReferences =
 211                 rule "blockReferences" $
 212                 element "references" $
 213                 DTC.BlockReferences
 214                  <$> positionXML
 215                  <*> commonAttrs
 216                  <*> many reference
 217         blockJudges = rule "blockJudges" $ DTC.BlockJudges <$> judges
 218         blockGrades =
 219                 rule "blockGrades" $
 220                 element "grades" $
 221                 DTC.BlockGrades
 222                  <$> positionXML
 223                  <*> commonAttrs
 224                  <*> some grade
 225         grade =
 226                 rule "grade" $
 227                 element "grade" $
 228                 DTC.Grade
 229                  <$> positionXML
 230                  <*> attribute "name" name
 231                  <*> attribute "color" text
 232                  <*> option False (True <$ attribute "default" text)
 233                  <*> optional title
 234
 235         para = rule "para" $
 236                 paraItems <|>             -- within  a <para>
 237                 DTC.ParaItem <$> paraItem -- without a <para>
 238         paraItem =
 239                 rule "paraItem" $
 240                 choice
 241                  [ element "ol"      $ DTC.ParaOL <$> many (element "li" $ DTC.ListItem <$> attribute "name" name <*> many para)
 242                  , element "ul"      $ DTC.ParaUL <$> many (element "li" $ many para)
 243                  , element "artwork" $ DTC.ParaArtwork <$> attribute "type" text <*> text
 244                  , element "quote"   $ DTC.ParaQuote   <$> attribute "type" text <*> many para
 245                  , DTC.ParaPlain . Seq.fromList <$> some plainNode
 246                  , DTC.ParaComment <$> comment
 247                  , DTC.ParaJudgment <$> judgment
 248                  ]
 249         paraItems =
 250                 rule "paraItems" $
 251                 element "para" $
 252                         DTC.ParaItems
 253                          <$> positionXML
 254                          <*> commonAttrs
 255                          <*> many paraItem
 256         plain = rule "plain" $ (Seq.fromList <$>) $ many plainNode
 257         plainNode =
 258                 rule "plainNode" $
 259                 choice
 260                  [ tree0 . DTC.PlainText <$> text
 261                  , element "br"   $ tree0   DTC.PlainBreak <$ none
 262                  , element "b"    $ Tree    DTC.PlainB     <$> plain
 263                  , element "code" $ Tree    DTC.PlainCode  <$> plain
 264                  , element "del"  $ Tree    DTC.PlainDel   <$> plain
 265                  , element "i"    $ Tree    DTC.PlainI     <$> plain
 266                  , element "q"    $ Tree    DTC.PlainQ     <$> plain
 267                  , element "sc"   $ Tree    DTC.PlainSC    <$> plain
 268                  , element "span" $ Tree .  DTC.PlainSpan  <$> commonAttrs <*> plain
 269                  , element "sub"  $ Tree    DTC.PlainSub   <$> plain
 270                  , element "sup"  $ Tree    DTC.PlainSup   <$> plain
 271                  , element "u"    $ Tree    DTC.PlainU     <$> plain
 272                  , element "note" $ tree0 . DTC.PlainNote  <$> many para
 273                  , element "iref" $ Tree .  DTC.PlainIref . Index.wordify <$> attribute "to" text <*> plain
 274                  , element "eref" $ Tree .  DTC.PlainEref <$> attribute "to" url <*> plain
 275                  , element "tag"      $ tree0 <$> (DTC.PlainTag <$> locationTCT <*> positionXML <*> to <*> pure False)
 276                  , element "tag-back" $ tree0 <$> (DTC.PlainTag <$> locationTCT <*> positionXML <*> to <*> pure True )
 277                  , element "at"       $ tree0 <$> (DTC.PlainAt  <$> locationTCT <*> positionXML <*> to <*> pure False)
 278                  , element "at-back"  $ tree0 <$> (DTC.PlainAt  <$> locationTCT <*> positionXML <*> to <*> pure True )
 279                  , element "ref"      $ Tree  <$> (DTC.PlainRef <$> locationTCT <*> positionXML <*> to) <*> plain
 280                  ]
 281         about =
 282                 about_known
 283                  <*> many header
 284                 where
 285                 about_known =
 286                         interleaved $
 287                         DTC.About
 288                          <$*> title
 289                          <|?> (def, Just <$> attribute "url" url)
 290                          <|*> author
 291                          <|?> (def, Just <$> editor)
 292                          <|?> (def, Just <$> date)
 293                          <|*> element "tag" text
 294                          <|*> link
 295                          <|*> serie
 296                          <|?> (def, Just <$> element "description" para)
 297         header =
 298                 rule "header" $
 299                 anyElem $ \n ->
 300                         DTC.Header (XML.nameLocal n)
 301                          <$> plain
 302         author = rule "author" $ element "author" entity
 303         editor = rule "editor" $ element "editor" entity
 304         entity = rule "entity" $
 305                 interleaved $
 306                 DTC.Entity
 307                  <$?> (def, attribute "name"    text)
 308                  <|?> (def, attribute "street"  text)
 309                  <|?> (def, attribute "zipcode" text)
 310                  <|?> (def, attribute "city"    text)
 311                  <|?> (def, attribute "region"  text)
 312                  <|?> (def, attribute "country" text)
 313                  <|?> (def, attribute "email"   text)
 314                  <|?> (def, attribute "tel"     text)
 315                  <|?> (def, attribute "fax"     text)
 316                  <|?> (def, Just <$> attribute "url" url)
 317                  <|?> (def, Just <$> element "org" entity)
 318         serie = rule "serie" $
 319                 element "serie" $
 320                 interleaved $
 321                 DTC.Serie
 322                  <$?> (def, attribute "name" name)
 323                  <|?> (def, attribute "id" text)
 324         link = rule "link" $
 325                 element "link" $
 326                 interleaved $
 327                 (\n h r t p -> DTC.Link n h r t (Seq.fromList p))
 328                  <$?> (def, attribute "name" name)
 329                  <|?> (def, attribute "href" url)
 330                  <|?> (def, attribute "rel"  text)
 331                  <|?> (def, Just <$> attribute "type" text)
 332                  <|*> plainNode
 333         alias = rule "alias" $
 334                 element "alias" $
 335                 DTC.Alias
 336                  <$> commonAttrs
 337                  <*> title
 338         reference = rule "reference" $
 339                 element "reference" $
 340                 DTC.Reference
 341                  <$> positionXML
 342                  <*> locationTCT
 343                  <*> id
 344                  <*> about
 345
 346         judgment =
 347                 rule "judgment" $
 348                 element "judgment" $
 349                 attrs
 350                  <*> many choice_
 351                 where
 352                 attrs =
 353                         interleaved $
 354                         DTC.Judgment def def def
 355                          <$$> positionXML
 356                          <||> locationTCT
 357                          <||> attribute "judges" ident
 358                          <||> attribute "grades" ident
 359                          <|?> (def, Just <$> attribute "importance" rationalPositive)
 360                          -- <|?> (def, Just <$> attribute "importance" (pure 0))
 361                          <|?> (def, Just <$> title)
 362         choice_ =
 363                 rule "choice" $
 364                 element "choice" $
 365                 DTC.Choice
 366                  <$> locationTCT
 367                  <*> positionXML
 368                  <*> optional title
 369                  <*> many opinion
 370         opinion =
 371                 rule "opinion" $
 372                 element "opinion" $
 373                 (interleaved $ DTC.Opinion
 374                  <$$> locationTCT
 375                  <||> positionXML
 376                  <|?> (def, attribute "judge" name)
 377                  <|?> (def, attribute "grade" name)
 378                  <|?> (def, Just <$> attribute "importance" rationalPositive))
 379                  -- <|?> (def, Just <$> attribute "importance" (pure 0)))
 380                  <*> optional title
 381         judges =
 382                 rule "judges" $
 383                 element "judges" $
 384                 DTC.Judges
 385                  <$> locationTCT
 386                  <*> positionXML
 387                  <*> commonAttrs
 388                  <*> judgesByName
 389                 where
 390                 judgesByName =
 391                         HM.fromListWith (flip (<>)) .
 392                         ((\j@DTC.Judge{..} -> (judge_name, pure j)) <$>)
 393                          <$> some judge
 394         judge =
 395                 rule "judge" $
 396                 element "judge" $
 397                 DTC.Judge
 398                  <$> locationTCT
 399                  <*> positionXML
 400                  <*> attribute "name" name
 401                  <*> optional title
 402                  <*> defaultGrades
 403                 where
 404                 defaultGrades =
 405                         HM.fromListWith (flip (<>)) .
 406                         (second pure <$>)
 407                          <$> many defaultGrade
 408                 defaultGrade =
 409                         rule "default" $
 410                         element "default" $
 411                         (,)
 412                          <$> attribute "grades" ident
 413                          <*> attribute "grade" (DTC.Name <$> text)
 414
 415 instance Sym_DTC RNC.Writer where
 416         positionXML = RNC.writeText ""
 417         locationTCT = RNC.writeText ""
 418 instance Sym_DTC RNC.RuleWriter where
 419         positionXML = RNC.RuleWriter positionXML
 420         locationTCT = RNC.RuleWriter locationTCT
 421
 422 -- | RNC schema for DTC
 423 schema :: [RNC.RuleWriter ()]
 424 schema =
 425  [ void $ document
 426
 427  , void $ head
 428  , void $ rule "about" $ element "about" about
 429  , void $ header
 430  , void $ author
 431  , void $ editor
 432  , void $ date
 433  , void $ entity
 434  , void $ link
 435  , void $ serie
 436  , void $ alias
 437  , void $ judgment
 438  , void $ choice_
 439  , void $ opinion
 440  , void $ judges
 441  , void $ judge
 442  , void $ grade
 443
 444  , void $ body
 445  , void $ include
 446
 447  , void $ block
 448  , void $ blockToC
 449  , void $ blockToF
 450  , void $ blockIndex
 451  , void $ blockFigure
 452  , void $ blockReferences
 453  , void $ reference
 454
 455  , void $ para
 456  , void $ paraItem
 457  , void $ paraItems
 458
 459  , void $ plain
 460  , void $ plainNode
 461
 462  , void $ commonAttrs
 463  , void $ ident
 464  , void $ title
 465  , void $ name
 466  , void $ url
 467  , void $ path
 468  , void $ to
 469  , void $ id
 470  ]