Language/DTC/Sym.hs

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