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.Monad (void)
   8 import Data.Default.Class (Default(..))
   9 import Data.Foldable (Foldable(..), concat)
  10 import Data.Function (($), (.))
  11 import Data.Maybe (Maybe(..), maybe)
  12 import Data.TreeSeq.Strict (Tree(..), tree0)
  13 import qualified Control.Applicative as Alt
  14 import qualified Data.Sequence as Seq
  15 import qualified Data.Text.Lazy as TL
  16
  17 import Hdoc.XML
  18 import Hdoc.RNC.Sym as RNC
  19 import Hdoc.DTC.Anchor (wordify)
  20 import qualified Hdoc.DTC.Document as DTC
  21 import qualified Hdoc.RNC.Write as RNC
  22
  23 -- Class 'Sym_DTC'
  24 -- | Use a symantic (tagless final) class to encode
  25 -- both the parsing and the schema of DTC,
  26 -- when repr is respectively instanciated
  27 -- on 'DTC.Parser' or 'RNC.RuleWriter'.
  28 class RNC.Sym_RNC repr => Sym_DTC repr where
  29         position         :: repr DTC.Pos
  30         document         :: repr DTC.Document
  31
  32         head             :: repr DTC.Head
  33         about            :: repr DTC.About
  34         header           :: repr DTC.Header
  35         tag              :: repr TL.Text
  36         author           :: repr DTC.Entity
  37         editor           :: repr DTC.Entity
  38         date             :: repr DTC.Date
  39         entity           :: repr DTC.Entity
  40         link             :: repr DTC.Link
  41         serie            :: repr DTC.Serie
  42         alias            :: repr DTC.Alias
  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         blockFigure      :: repr DTC.Block
  53         blockReferences  :: 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 TL.Text
  67         url              :: repr URL
  68         path             :: repr Path
  69         to               :: repr Ident
  70         id               :: repr Ident
  71
  72         commonAttrs =
  73                 rule "commonAttrs" $
  74                 interleaved $
  75                 DTC.CommonAttrs
  76                  <$?> (def, Just <$> id)
  77                  <|?> (def, rule "class" $ attribute "class" $ TL.words <$> text)
  78
  79         document = rule "document" $
  80                 DTC.Document
  81                  <$> head
  82                  <*> body
  83         head = rule "head" $
  84                 maybe def DTC.Head
  85                  <$> optional (rule "about" $ element "about" about)
  86         body =
  87                 rule "body" $
  88                 (Seq.fromList <$>) $
  89                 many $
  90                         choice
  91                          [ element "section" $ Tree <$> section <*> body
  92                          , tree0 . DTC.BodyBlock <$> block
  93                          ]
  94                 where
  95                 section =
  96                         DTC.BodySection
  97                          <$> position
  98                          <*> commonAttrs
  99                          <*> title
 100                          <*> many alias
 101         title = rule "title" $ DTC.Title <$> element "title" plain
 102         name  = rule "name"  $ attribute "name" text
 103         url   = rule "url"   $ URL   <$> text
 104         path  = rule "path"  $ Path  <$> text
 105         ident = rule "ident" $ Ident <$> text
 106         to    = rule "to"    $ attribute "to" ident
 107         id    = rule "id"    $ attribute "id" ident
 108         date  = rule "date"  $
 109                 element "date" $
 110                 interleaved $
 111                 DTC.Date
 112                  <$?> (0, attribute "year" int)
 113                  <|?> (Nothing, Just <$> attribute "month" nat1)
 114                  <|?> (Nothing, Just <$> attribute "day"   nat1)
 115         include =
 116                 rule "include"  $
 117                 element "include" $
 118                 interleaved $
 119                 DTC.Include
 120                  <$?> (def, attribute "href" path)
 121         block = rule "block" $
 122                 choice
 123                  [ DTC.BlockPara <$> para
 124                  , blockBreak
 125                  , blockToC
 126                  , blockToF
 127                  , blockIndex
 128                  , blockFigure
 129                  , blockReferences
 130                  {-
 131                  , anyElem $ \n@XmlName{..} ->
 132                                 case xmlNameSpace of
 133                                  "" -> figure n
 134                  -}
 135                  ]
 136         blockBreak = rule "break" $
 137                 element "break" $
 138                 DTC.BlockBreak
 139                  <$> commonAttrs
 140         blockToC =
 141                 rule "blockToC" $
 142                 element "toc" $
 143                 DTC.BlockToC
 144                  <$> position
 145                  <*> commonAttrs
 146                  <*> optional (attribute "depth" nat)
 147         blockToF =
 148                 rule "blockToF" $
 149                 element "tof" $
 150                 DTC.BlockToF
 151                  <$> position
 152                  <*> commonAttrs
 153                  <*> option [] (
 154                         element "ul" $
 155                                 many $
 156                                         element "li" $
 157                                                 element "para" text)
 158         blockIndex =
 159                 rule "blockIndex" $
 160                 element "index" $
 161                 DTC.BlockIndex
 162                  <$> position
 163                  <*> commonAttrs
 164                  <*> option [] (
 165                         element "ul" $
 166                                 many $
 167                                         element "li" $
 168                                                 element "para" $
 169                                                         (concat <$>) $
 170                                                         many $
 171                                                                 (wordify <$>) . TL.lines <$> text)
 172         blockFigure =
 173                 rule "blockFigure" $
 174                 element "figure" $
 175                 DTC.BlockFigure
 176                  <$> position
 177                  <*> commonAttrs
 178                  <*> attribute "type" text
 179                  <*> optional title
 180                  <*> many para
 181         blockReferences =
 182                 rule "blockReferences" $
 183                 element "references" $
 184                 DTC.BlockReferences
 185                  <$> position
 186                  <*> commonAttrs
 187                  <*> many reference
 188
 189         para = rule "para" $ paraItems <|> DTC.ParaItem <$> paraItem
 190         paraItem =
 191                 rule "paraItem" $
 192                 choice
 193                  [ element "ol"      $ DTC.ParaOL <$> many (element "li" $ DTC.ListItem <$> attribute "name" text <*> many para)
 194                  , element "ul"      $ DTC.ParaUL <$> many (element "li" $ many para)
 195                  , element "artwork" $ DTC.ParaArtwork <$> attribute "type" text <*> text
 196                  , element "quote"   $ DTC.ParaQuote   <$> attribute "type" text <*> many para
 197                  , DTC.ParaPlain . Seq.fromList <$> some plainNode
 198                  , DTC.ParaComment <$> comment
 199                  ]
 200         paraItems =
 201                 rule "paraItems" $
 202                 element "para" $
 203                         DTC.ParaItems
 204                          <$> position
 205                          <*> commonAttrs
 206                          <*> many paraItem
 207         plain = rule "plain" $ (Seq.fromList <$>) $ many plainNode
 208         plainNode =
 209                 rule "plainNode" $
 210                 choice
 211                  [ tree0 . DTC.PlainText <$> text
 212                  , element "br"   $ tree0   DTC.PlainBreak <$ none
 213                  , element "b"    $ Tree    DTC.PlainB     <$> plain
 214                  , element "code" $ Tree    DTC.PlainCode  <$> plain
 215                  , element "del"  $ Tree    DTC.PlainDel   <$> plain
 216                  , element "i"    $ Tree    DTC.PlainI     <$> plain
 217                  , element "q"    $ Tree    DTC.PlainQ     <$> plain
 218                  , element "sc"   $ Tree    DTC.PlainSC    <$> plain
 219                  , element "span" $ Tree .  DTC.PlainSpan  <$> commonAttrs <*> plain
 220                  , element "sub"  $ Tree    DTC.PlainSub   <$> plain
 221                  , element "sup"  $ Tree    DTC.PlainSup   <$> plain
 222                  , element "u"    $ Tree    DTC.PlainU     <$> plain
 223                  , element "note" $ tree0 . DTC.PlainNote Nothing <$> many para
 224                  , element "iref" $ Tree .  DTC.PlainIref Nothing . wordify <$> attribute "to" text <*> plain
 225                  , element "eref" $ Tree .  DTC.PlainEref <$> attribute "to" url <*> plain
 226                  , element "ref"  $ Tree .  DTC.PlainRef  <$> to <*> plain
 227                  , element "rref" $ Tree .  DTC.PlainRref Nothing <$> to <*> plain
 228                  ]
 229         tag = rule "tag" $ element "tag" text
 230         about =
 231                 (foldr ($) def <$>) $
 232                 many $ choice
 233                  [ (\a acc -> acc{DTC.titles=a:DTC.titles acc})              <$> title
 234                  , (\a acc -> (acc::DTC.About){DTC.url=Just a})              <$> attribute "url" url
 235                  , (\a acc -> acc{DTC.authors=a:DTC.authors acc})            <$> author
 236                  , (\a acc -> acc{DTC.editor=DTC.editor acc Alt.<|> Just a}) <$> editor
 237                  , (\a acc -> acc{DTC.date=DTC.date acc Alt.<|> Just a})     <$> date
 238                  , (\a acc -> acc{DTC.tags=a:DTC.tags acc})                  <$> tag
 239                  , (\a acc -> acc{DTC.links=a:DTC.links acc})                <$> link
 240                  , (\a acc -> acc{DTC.series=a:DTC.series acc})              <$> serie
 241                  , (\a acc -> acc{DTC.headers=a:DTC.headers acc})            <$> header
 242                  ]
 243         header =
 244                 rule "header" $
 245                 anyElem $ \n ->
 246                         DTC.Header (xmlNameLocal n)
 247                          <$> plain
 248         author = rule "author" $ element "author" entity
 249         editor = rule "editor" $ element "editor" entity
 250         entity = rule "entity" $
 251                 interleaved $
 252                 DTC.Entity
 253                  <$?> (def, name)
 254                  <|?> (def, attribute "street"  text)
 255                  <|?> (def, attribute "zipcode" text)
 256                  <|?> (def, attribute "city"    text)
 257                  <|?> (def, attribute "region"  text)
 258                  <|?> (def, attribute "country" text)
 259                  <|?> (def, attribute "email"   text)
 260                  <|?> (def, attribute "tel"     text)
 261                  <|?> (def, attribute "fax"     text)
 262                  <|?> (def, Just <$> attribute "url" url)
 263                  <|?> (def, Just <$> element "org" entity)
 264         serie = rule "serie" $
 265                 element "serie" $
 266                 interleaved $
 267                 DTC.Serie
 268                  <$?> (def, name)
 269                  <|?> (def, attribute "id" text)
 270         link = rule "link" $
 271                 element "link" $
 272                 interleaved $
 273                 (\n h r t p -> DTC.Link n h r t (Seq.fromList p))
 274                  <$?> (def, name)
 275                  <|?> (def, attribute "href" url)
 276                  <|?> (def, attribute "rel"  text)
 277                  <|?> (def, Just <$> attribute "type" text)
 278                  <|*> plainNode
 279         alias = rule "alias" $
 280                 element "alias" $
 281                 interleaved $
 282                 DTC.Alias
 283                  <$?> (def, id)
 284         reference = rule "reference" $
 285                 element "reference" $
 286                 DTC.Reference
 287                  <$> id
 288                  <*> about
 289
 290 instance Sym_DTC RNC.Writer where
 291         position = RNC.writeText ""
 292 instance Sym_DTC RNC.RuleWriter where
 293         position = RNC.RuleWriter position
 294
 295 -- | RNC schema for DTC
 296 schema :: [RNC.RuleWriter ()]
 297 schema =
 298  [ void $ document
 299
 300  , void $ head
 301  , void $ rule "about" $ element "about" about
 302  , void $ header
 303  , void $ tag
 304  , void $ author
 305  , void $ editor
 306  , void $ date
 307  , void $ entity
 308  , void $ link
 309  , void $ serie
 310  , void $ alias
 311
 312  , void $ body
 313  , void $ include
 314
 315  , void $ block
 316  , void $ blockToC
 317  , void $ blockToF
 318  , void $ blockIndex
 319  , void $ blockFigure
 320  , void $ blockReferences
 321  , void $ reference
 322
 323  , void $ para
 324  , void $ paraItem
 325  , void $ paraItems
 326
 327  , void $ plain
 328  , void $ plainNode
 329
 330  , void $ commonAttrs
 331  , void $ ident
 332  , void $ title
 333  , void $ name
 334  , void $ url
 335  , void $ path
 336  , void $ to
 337  , void $ id
 338  ]