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