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         tag              :: repr TL.Text
  42
  43         body             :: repr DTC.Body
  44         include          :: repr DTC.Include
  45
  46         block            :: repr DTC.Block
  47         blockBreak       :: repr DTC.Block
  48         blockToC         :: repr DTC.Block
  49         blockToF         :: repr DTC.Block
  50         blockIndex       :: repr DTC.Block
  51         blockAside       :: repr DTC.Block
  52         blockFigure      :: repr DTC.Block
  53         blockReferences  :: repr DTC.Block
  54         blockJudges      :: repr DTC.Block
  55         blockGrades      :: repr DTC.Block
  56         reference        :: repr DTC.Reference
  57
  58         para             :: repr DTC.Para
  59         paraItem         :: repr DTC.ParaItem
  60         paraItems        :: repr DTC.Para
  61
  62         plain            :: repr DTC.Plain
  63         plainNode        :: repr (Tree DTC.PlainNode)
  64
  65         commonAttrs      :: repr DTC.CommonAttrs
  66         ident            :: repr Ident
  67         title            :: repr DTC.Title
  68         name             :: repr DTC.Name
  69         url              :: repr URL
  70         path             :: repr DTC.FilePath
  71         to               :: repr Ident
  72         id               :: repr Ident
  73         class_           :: repr [TL.Text]
  74
  75         author           :: repr DTC.Entity
  76         editor           :: repr DTC.Entity
  77         date             :: repr DTC.Date
  78         entity           :: repr DTC.Entity
  79         link             :: repr DTC.Link
  80         serie            :: repr DTC.Serie
  81         alias            :: repr DTC.Alias
  82         judgment         :: repr DTC.Judgment
  83         choice_          :: repr DTC.Choice
  84         opinion          :: repr DTC.Opinion
  85         judges           :: repr DTC.Judges
  86         judge            :: repr DTC.Judge
  87         grade            :: repr DTC.Grade
  88
  89         document = rule "document" $
  90                 DTC.Document
  91                  <$> head
  92                  <*> body
  93         head = rule "head" $
  94                 interleaved $
  95                 DTC.Head
  96                  <$?> (def, rule "about" $ element "about" about)
  97                  <|*> judgment
  98         body =
  99                 rule "body" $
 100                 (Seq.fromList <$>) $
 101                 many $
 102                         choice
 103                          [ element "section" $ Tree . DTC.BodySection <$> section <*> body
 104                          , tree0 . DTC.BodyBlock <$> block
 105                          ]
 106                 where
 107                 section =
 108                         DTC.Section
 109                          <$> positionXML
 110                          <*> commonAttrs
 111                          <*> title
 112                          <*> many alias
 113                          <*> many judgment
 114         title = rule "title" $ DTC.Title <$> element "title" plain
 115         name  = rule "name"  $ DTC.Name <$> text
 116         url   = rule "url"   $ URL <$> text
 117         path  = rule "path"  $ TL.unpack <$> text
 118         ident = rule "ident" $ Ident <$> text
 119         to    = rule "to"    $ attribute "to" ident
 120         commonAttrs =
 121                 rule "commonAttrs" $
 122                 interleaved $
 123                 DTC.CommonAttrs
 124                  <$?> (def, Just <$> id)
 125                  <|?> (def, class_)
 126         id     = rule "id"    $ attribute "id" ident
 127         class_ = rule "class" $ attribute "class" $ TL.words <$> text
 128         date = rule "date"  $
 129                 element "date" $
 130                 interleaved $
 131                 DTC.Date
 132                  <$?> (0, attribute "year" int)
 133                  <|?> (Nothing, Just <$> attribute "month" nat1)
 134                  <|?> (Nothing, Just <$> attribute "day"   nat1)
 135         include =
 136                 rule "include"  $
 137                 element "include" $
 138                 interleaved $
 139                 DTC.Include
 140                  <$?> (def, attribute "href" path)
 141         block = rule "block" $
 142                 choice
 143                  [ DTC.BlockPara <$> para
 144                  , blockBreak
 145                  , blockToC
 146                  , blockToF
 147                  , blockIndex
 148                  , blockAside
 149                  , blockFigure
 150                  , blockReferences
 151                  , blockJudges
 152                  , blockGrades
 153                  {-
 154                  , anyElem $ \n@XmlName{..} ->
 155                                 case xmlNameSpace of
 156                                  "" -> figure n
 157                  -}
 158                  ]
 159         blockBreak = rule "break" $
 160                 element "break" $
 161                 DTC.BlockBreak
 162                  <$> commonAttrs
 163         blockToC =
 164                 rule "blockToC" $
 165                 element "toc" $
 166                 DTC.BlockToC
 167                  <$> positionXML
 168                  <*> commonAttrs
 169                  <*> optional (attribute "depth" nat)
 170         blockToF =
 171                 rule "blockToF" $
 172                 element "tof" $
 173                 DTC.BlockToF
 174                  <$> positionXML
 175                  <*> commonAttrs
 176                  <*> option [] (
 177                         element "ul" $
 178                                 many $
 179                                         element "li" $
 180                                                 element "para" text)
 181         blockIndex =
 182                 rule "blockIndex" $
 183                 element "index" $
 184                 DTC.BlockIndex
 185                  <$> positionXML
 186                  <*> commonAttrs
 187                  <*> option [] (
 188                         element "ul" $
 189                                 many $
 190                                         element "li" $
 191                                                 element "para" $
 192                                                         (concat <$>) $
 193                                                         many $
 194                                                                 (Index.wordify <$>) . TL.lines <$> text)
 195         blockAside =
 196                 rule "blockAside" $
 197                 element "aside" $
 198                 DTC.BlockAside
 199                  <$> positionXML
 200                  <*> commonAttrs
 201                  <*> many block
 202         blockFigure =
 203                 rule "blockFigure" $
 204                 element "figure" $
 205                 DTC.BlockFigure
 206                  <$> positionXML
 207                  <*> attribute "type" text
 208                  <*> commonAttrs
 209                  <*> optional title
 210                  <*> many para
 211         blockReferences =
 212                 rule "blockReferences" $
 213                 element "references" $
 214                 DTC.BlockReferences
 215                  <$> positionXML
 216                  <*> commonAttrs
 217                  <*> many reference
 218         blockJudges = rule "blockJudges" $ DTC.BlockJudges <$> judges
 219         blockGrades =
 220                 rule "blockGrades" $
 221                 element "grades" $
 222                 DTC.BlockGrades
 223                  <$> positionXML
 224                  <*> commonAttrs
 225                  <*> some grade
 226         grade =
 227                 rule "grade" $
 228                 element "grade" $
 229                 DTC.Grade
 230                  <$> positionXML
 231                  <*> attribute "name" name
 232                  <*> attribute "color" text
 233                  <*> option False (True <$ attribute "default" text)
 234                  <*> optional title
 235
 236         para = rule "para" $
 237                 paraItems <|>             -- within  a <para>
 238                 DTC.ParaItem <$> paraItem -- without a <para>
 239         paraItem =
 240                 rule "paraItem" $
 241                 choice
 242                  [ element "ol"      $ DTC.ParaOL <$> many (element "li" $ DTC.ListItem <$> attribute "name" name <*> many para)
 243                  , element "ul"      $ DTC.ParaUL <$> many (element "li" $ many para)
 244                  , element "artwork" $ DTC.ParaArtwork <$> attribute "type" text <*> text
 245                  , element "quote"   $ DTC.ParaQuote   <$> attribute "type" text <*> many para
 246                  , DTC.ParaPlain . Seq.fromList <$> some plainNode
 247                  , DTC.ParaComment <$> comment
 248                  , DTC.ParaJudgment <$> judgment
 249                  ]
 250         paraItems =
 251                 rule "paraItems" $
 252                 element "para" $
 253                         DTC.ParaItems
 254                          <$> positionXML
 255                          <*> commonAttrs
 256                          <*> many paraItem
 257         plain = rule "plain" $ (Seq.fromList <$>) $ many plainNode
 258         plainNode =
 259                 rule "plainNode" $
 260                 choice
 261                  [ tree0 . DTC.PlainText <$> text
 262                  , element "br"   $ tree0   DTC.PlainBreak <$ none
 263                  , element "b"    $ Tree    DTC.PlainB     <$> plain
 264                  , element "code" $ Tree    DTC.PlainCode  <$> plain
 265                  , element "del"  $ Tree    DTC.PlainDel   <$> plain
 266                  , element "i"    $ Tree    DTC.PlainI     <$> plain
 267                  , element "q"    $ Tree    DTC.PlainQ     <$> plain
 268                  , element "sc"   $ Tree    DTC.PlainSC    <$> plain
 269                  , element "span" $ Tree .  DTC.PlainSpan  <$> commonAttrs <*> plain
 270                  , element "sub"  $ Tree    DTC.PlainSub   <$> plain
 271                  , element "sup"  $ Tree    DTC.PlainSup   <$> plain
 272                  , element "u"    $ Tree    DTC.PlainU     <$> plain
 273                  , element "note" $ tree0 . DTC.PlainNote  <$> many para
 274                  , element "iref" $ Tree .  DTC.PlainIref . Index.wordify <$> attribute "to" text <*> plain
 275                  , element "eref" $ Tree .  DTC.PlainEref <$> attribute "to" url <*> plain
 276                  , element "tag"  $ tree0 <$> (DTC.PlainTag <$> locationTCT <*> positionXML <*> ident)
 277                  , element "rref" $ Tree <$> (DTC.PlainRref <$> locationTCT <*> positionXML <*> to) <*> plain
 278                  ]
 279         tag = rule "tag" $ element "tag" text
 280         about =
 281                 about_known
 282                  <*> many header
 283                 where
 284                 about_known =
 285                         interleaved $
 286                         DTC.About
 287                          <$*> title
 288                          <|?> (def, Just <$> attribute "url" url)
 289                          <|*> author
 290                          <|?> (def, Just <$> editor)
 291                          <|?> (def, Just <$> date)
 292                          <|*> tag
 293                          <|*> link
 294                          <|*> serie
 295                          <|?> (def, Just <$> element "description" para)
 296         header =
 297                 rule "header" $
 298                 anyElem $ \n ->
 299                         DTC.Header (XML.nameLocal n)
 300                          <$> plain
 301         author = rule "author" $ element "author" entity
 302         editor = rule "editor" $ element "editor" entity
 303         entity = rule "entity" $
 304                 interleaved $
 305                 DTC.Entity
 306                  <$?> (def, attribute "name"    text)
 307                  <|?> (def, attribute "street"  text)
 308                  <|?> (def, attribute "zipcode" text)
 309                  <|?> (def, attribute "city"    text)
 310                  <|?> (def, attribute "region"  text)
 311                  <|?> (def, attribute "country" text)
 312                  <|?> (def, attribute "email"   text)
 313                  <|?> (def, attribute "tel"     text)
 314                  <|?> (def, attribute "fax"     text)
 315                  <|?> (def, Just <$> attribute "url" url)
 316                  <|?> (def, Just <$> element "org" entity)
 317         serie = rule "serie" $
 318                 element "serie" $
 319                 interleaved $
 320                 DTC.Serie
 321                  <$?> (def, attribute "name" name)
 322                  <|?> (def, attribute "id" text)
 323         link = rule "link" $
 324                 element "link" $
 325                 interleaved $
 326                 (\n h r t p -> DTC.Link n h r t (Seq.fromList p))
 327                  <$?> (def, attribute "name" name)
 328                  <|?> (def, attribute "href" url)
 329                  <|?> (def, attribute "rel"  text)
 330                  <|?> (def, Just <$> attribute "type" text)
 331                  <|*> plainNode
 332         alias = rule "alias" $
 333                 element "alias" $
 334                 DTC.Alias
 335                  <$> commonAttrs
 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  ]