Hdoc/DTC/Sym.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 module Hdoc.DTC.Sym where
   5
   6 import Data.Bool (Bool(..))
   7 import Control.Applicative (Applicative(..), (<$>), (<$))
   8 import Control.Monad (void)
   9 import Data.Default.Class (Default(..))
  10 import Data.Foldable (Foldable(..), concat)
  11 import Data.Function (($), (.))
  12 import Data.Maybe (Maybe(..))
  13 import Data.TreeSeq.Strict (Tree(..), tree0)
  14 import qualified Control.Applicative as Alt
  15 import qualified Data.Sequence as Seq
  16 import qualified Data.Text.Lazy as TL
  17
  18 import Hdoc.XML
  19 import Hdoc.RNC.Sym as RNC
  20 import Hdoc.DTC.Index (wordify)
  21 import qualified Hdoc.DTC.Document as DTC
  22 import qualified Hdoc.RNC.Write as RNC
  23
  24 -- Class 'Sym_DTC'
  25 -- | Use a symantic (tagless final) class to encode
  26 -- both the parsing and the schema of DTC,
  27 -- when repr is respectively instanciated
  28 -- on 'DTC.Parser' or 'RNC.RuleWriter'.
  29 class RNC.Sym_RNC repr => Sym_DTC repr where
  30         position         :: repr DTC.Pos
  31         document         :: repr DTC.Document
  32
  33         head             :: repr DTC.Head
  34         about            :: repr DTC.About
  35         header           :: repr DTC.Header
  36         tag              :: repr TL.Text
  37
  38         body             :: repr DTC.Body
  39         include          :: repr DTC.Include
  40
  41         block            :: repr DTC.Block
  42         blockBreak       :: repr DTC.Block
  43         blockToC         :: repr DTC.Block
  44         blockToF         :: repr DTC.Block
  45         blockIndex       :: repr DTC.Block
  46         blockAside       :: repr DTC.Block
  47         blockFigure      :: repr DTC.Block
  48         blockReferences  :: repr DTC.Block
  49         blockJudges      :: repr DTC.Block
  50         blockGrades      :: repr DTC.Block
  51         reference        :: repr DTC.Reference
  52
  53         para             :: repr DTC.Para
  54         paraItem         :: repr DTC.ParaItem
  55         paraItems        :: repr DTC.Para
  56
  57         plain            :: repr DTC.Plain
  58         plainNode        :: repr (Tree DTC.PlainNode)
  59
  60         commonAttrs      :: repr DTC.CommonAttrs
  61         ident            :: repr Ident
  62         title            :: repr DTC.Title
  63         name             :: repr DTC.Name
  64         url              :: repr URL
  65         path             :: repr Path
  66         to               :: repr Ident
  67         id               :: repr Ident
  68         class_           :: repr [TL.Text]
  69
  70         author           :: repr DTC.Entity
  71         editor           :: repr DTC.Entity
  72         date             :: repr DTC.Date
  73         entity           :: repr DTC.Entity
  74         link             :: repr DTC.Link
  75         serie            :: repr DTC.Serie
  76         alias            :: repr DTC.Alias
  77         judgment         :: repr DTC.Judgment
  78         choice_          :: repr DTC.Choice
  79         opinion          :: repr DTC.Opinion
  80         judge            :: repr DTC.Judge
  81         grade            :: repr DTC.Grade
  82
  83         document = rule "document" $
  84                 DTC.Document
  85                  <$> head
  86                  <*> body
  87         head = rule "head" $
  88                 interleaved $
  89                 DTC.Head
  90                  <$?> (def, rule "about" $ element "about" about)
  91                  <|*> judgment
  92         body =
  93                 rule "body" $
  94                 (Seq.fromList <$>) $
  95                 many $
  96                         choice
  97                          [ element "section" $ Tree <$> section <*> body
  98                          , tree0 . DTC.BodyBlock <$> block
  99                          ]
 100                 where
 101                 section =
 102                         DTC.BodySection
 103                          <$> position
 104                          <*> commonAttrs
 105                          <*> title
 106                          <*> many alias
 107                          <*> many judgment
 108         title = rule "title" $ DTC.Title <$> element "title" plain
 109         name  = rule "name"  $ DTC.Name <$> text
 110         url   = rule "url"   $ URL   <$> text
 111         path  = rule "path"  $ Path  <$> text
 112         ident = rule "ident" $ Ident <$> text
 113         to    = rule "to"    $ attribute "to" ident
 114         commonAttrs =
 115                 rule "commonAttrs" $
 116                 interleaved $
 117                 DTC.CommonAttrs
 118                  <$?> (def, Just <$> id)
 119                  <|?> (def, class_)
 120         id     = rule "id"    $ attribute "id" ident
 121         class_ = rule "class" $ attribute "class" $ TL.words <$> text
 122         date = rule "date"  $
 123                 element "date" $
 124                 interleaved $
 125                 DTC.Date
 126                  <$?> (0, attribute "year" int)
 127                  <|?> (Nothing, Just <$> attribute "month" nat1)
 128                  <|?> (Nothing, Just <$> attribute "day"   nat1)
 129         include =
 130                 rule "include"  $
 131                 element "include" $
 132                 interleaved $
 133                 DTC.Include
 134                  <$?> (def, attribute "href" path)
 135         block = rule "block" $
 136                 choice
 137                  [ DTC.BlockPara <$> para
 138                  , blockBreak
 139                  , blockToC
 140                  , blockToF
 141                  , blockIndex
 142                  , blockAside
 143                  , blockFigure
 144                  , blockReferences
 145                  , blockJudges
 146                  , blockGrades
 147                  {-
 148                  , anyElem $ \n@XmlName{..} ->
 149                                 case xmlNameSpace of
 150                                  "" -> figure n
 151                  -}
 152                  ]
 153         blockBreak = rule "break" $
 154                 element "break" $
 155                 DTC.BlockBreak
 156                  <$> commonAttrs
 157         blockToC =
 158                 rule "blockToC" $
 159                 element "toc" $
 160                 DTC.BlockToC
 161                  <$> position
 162                  <*> commonAttrs
 163                  <*> optional (attribute "depth" nat)
 164         blockToF =
 165                 rule "blockToF" $
 166                 element "tof" $
 167                 DTC.BlockToF
 168                  <$> position
 169                  <*> commonAttrs
 170                  <*> option [] (
 171                         element "ul" $
 172                                 many $
 173                                         element "li" $
 174                                                 element "para" text)
 175         blockIndex =
 176                 rule "blockIndex" $
 177                 element "index" $
 178                 DTC.BlockIndex
 179                  <$> position
 180                  <*> commonAttrs
 181                  <*> option [] (
 182                         element "ul" $
 183                                 many $
 184                                         element "li" $
 185                                                 element "para" $
 186                                                         (concat <$>) $
 187                                                         many $
 188                                                                 (wordify <$>) . TL.lines <$> text)
 189         blockAside =
 190                 rule "blockAside" $
 191                 element "aside" $
 192                 DTC.BlockAside
 193                  <$> position
 194                  <*> commonAttrs
 195                  <*> many block
 196         blockFigure =
 197                 rule "blockFigure" $
 198                 element "figure" $
 199                 DTC.BlockFigure
 200                  <$> position
 201                  <*> attribute "type" text
 202                  <*> commonAttrs
 203                  <*> optional title
 204                  <*> many para
 205         blockReferences =
 206                 rule "blockReferences" $
 207                 element "references" $
 208                 DTC.BlockReferences
 209                  <$> position
 210                  <*> commonAttrs
 211                  <*> many reference
 212         blockJudges =
 213                 rule "blockJudges" $
 214                 element "judges" $
 215                 DTC.BlockJudges
 216                  <$> position
 217                  <*> commonAttrs
 218                  <*> many judge
 219         blockGrades =
 220                 rule "blockGrades" $
 221                 element "grades" $
 222                 DTC.BlockGrades
 223                  <$> position
 224                  <*> commonAttrs
 225                  <*> many grade
 226         grade =
 227                 rule "grade" $
 228                 element "grade" $
 229                 DTC.Grade
 230                  <$> position
 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                          <$> position
 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 Nothing <$> many para
 274                  , element "iref" $ Tree .  DTC.PlainIref Nothing . wordify <$> attribute "to" text <*> plain
 275                  , element "eref" $ Tree .  DTC.PlainEref <$> attribute "to" url <*> plain
 276                  , element "ref"  $ Tree .  DTC.PlainRef  <$> to <*> plain
 277                  , element "rref" $ Tree .  DTC.PlainRref Nothing <$> to <*> plain
 278                  ]
 279         tag = rule "tag" $ element "tag" text
 280         about =
 281                 (foldr ($) def <$>) $
 282                 many $ choice
 283                  [ (\a acc -> acc{DTC.titles=a:DTC.titles acc})              <$> title
 284                  , (\a acc -> (acc::DTC.About){DTC.url=Just a})              <$> attribute "url" url
 285                  , (\a acc -> acc{DTC.authors=a:DTC.authors acc})            <$> author
 286                  , (\a acc -> acc{DTC.editor=DTC.editor acc Alt.<|> Just a}) <$> editor
 287                  , (\a acc -> acc{DTC.date=DTC.date acc Alt.<|> Just a})     <$> date
 288                  , (\a acc -> acc{DTC.tags=a:DTC.tags acc})                  <$> tag
 289                  , (\a acc -> acc{DTC.links=a:DTC.links acc})                <$> link
 290                  , (\a acc -> acc{DTC.series=a:DTC.series acc})              <$> serie
 291                  , (\a acc -> acc{DTC.headers=a:DTC.headers acc})            <$> header
 292                  ]
 293         header =
 294                 rule "header" $
 295                 anyElem $ \n ->
 296                         DTC.Header (xmlNameLocal n)
 297                          <$> plain
 298         author = rule "author" $ element "author" entity
 299         editor = rule "editor" $ element "editor" entity
 300         entity = rule "entity" $
 301                 interleaved $
 302                 DTC.Entity
 303                  <$?> (def, attribute "name"    text)
 304                  <|?> (def, attribute "street"  text)
 305                  <|?> (def, attribute "zipcode" text)
 306                  <|?> (def, attribute "city"    text)
 307                  <|?> (def, attribute "region"  text)
 308                  <|?> (def, attribute "country" text)
 309                  <|?> (def, attribute "email"   text)
 310                  <|?> (def, attribute "tel"     text)
 311                  <|?> (def, attribute "fax"     text)
 312                  <|?> (def, Just <$> attribute "url" url)
 313                  <|?> (def, Just <$> element "org" entity)
 314         serie = rule "serie" $
 315                 element "serie" $
 316                 interleaved $
 317                 DTC.Serie
 318                  <$?> (def, attribute "name" name)
 319                  <|?> (def, attribute "id" text)
 320         link = rule "link" $
 321                 element "link" $
 322                 interleaved $
 323                 (\n h r t p -> DTC.Link n h r t (Seq.fromList p))
 324                  <$?> (def, attribute "name" name)
 325                  <|?> (def, attribute "href" url)
 326                  <|?> (def, attribute "rel"  text)
 327                  <|?> (def, Just <$> attribute "type" text)
 328                  <|*> plainNode
 329         alias = rule "alias" $
 330                 element "alias" $
 331                 interleaved $
 332                 DTC.Alias
 333                  <$?> (def, id)
 334         reference = rule "reference" $
 335                 element "reference" $
 336                 DTC.Reference
 337                  <$> id
 338                  <*> about
 339
 340         judgment =
 341                 rule "judgment" $
 342                 element "judgment" $
 343                 attrs
 344                  <*> many choice_
 345                 where
 346                 attrs =
 347                         interleaved $
 348                         DTC.Judgment Nothing
 349                          <$$> attribute "judges" ident
 350                          <||> attribute "grades" ident
 351                          <|?> (def, Just <$> attribute "importance" rationalPositive)
 352                          <|?> (def, Just <$> title)
 353         choice_ =
 354                 rule "choice" $
 355                 element "choice" $
 356                 DTC.Choice
 357                  <$> optional title
 358                  <*> many opinion
 359         opinion =
 360                 rule "opinion" $
 361                 element "opinion" $
 362                 (interleaved $ DTC.Opinion
 363                  <$?> (def, attribute "judge" name)
 364                  <|?> (def, attribute "grade" name)
 365                  <|?> (def, Just <$> attribute "importance" rationalPositive))
 366                  <*> optional title
 367         judge =
 368                 rule "judge" $
 369                 element "judge" $
 370                 DTC.Judge
 371                  <$> attribute "name" name
 372                  <*> optional title
 373                  <*> many defaultGrade
 374                 where
 375                 defaultGrade =
 376                         rule "default" $
 377                         element "default" $
 378                         (,)
 379                          <$> attribute "grades" ident
 380                          <*> attribute "grade" (DTC.Name <$> text)
 381
 382 instance Sym_DTC RNC.Writer where
 383         position = RNC.writeText ""
 384 instance Sym_DTC RNC.RuleWriter where
 385         position = RNC.RuleWriter position
 386
 387 -- | RNC schema for DTC
 388 schema :: [RNC.RuleWriter ()]
 389 schema =
 390  [ void $ document
 391
 392  , void $ head
 393  , void $ rule "about" $ element "about" about
 394  , void $ header
 395  , void $ tag
 396  , void $ author
 397  , void $ editor
 398  , void $ date
 399  , void $ entity
 400  , void $ link
 401  , void $ serie
 402  , void $ alias
 403  , void $ judgment
 404  , void $ choice_
 405  , void $ opinion
 406  , void $ judge
 407  , void $ grade
 408
 409  , void $ body
 410  , void $ include
 411
 412  , void $ block
 413  , void $ blockToC
 414  , void $ blockToF
 415  , void $ blockIndex
 416  , void $ blockFigure
 417  , void $ blockReferences
 418  , void $ reference
 419
 420  , void $ para
 421  , void $ paraItem
 422  , void $ paraItems
 423
 424  , void $ plain
 425  , void $ plainNode
 426
 427  , void $ commonAttrs
 428  , void $ ident
 429  , void $ title
 430  , void $ name
 431  , void $ url
 432  , void $ path
 433  , void $ to
 434  , void $ id
 435  ]