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