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         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 "sub"  $ Tree    DTC.PlainSub   <$> plain
 220                  , element "sup"  $ Tree    DTC.PlainSup   <$> plain
 221                  , element "u"    $ Tree    DTC.PlainU     <$> plain
 222                  , element "note" $ tree0 . DTC.PlainNote Nothing <$> many para
 223                  , element "iref" $ Tree .  DTC.PlainIref Nothing . wordify <$> attribute "to" text <*> plain
 224                  , element "eref" $ Tree .  DTC.PlainEref <$> attribute "to" url <*> plain
 225                  , element "ref"  $ Tree .  DTC.PlainRef  <$> to <*> plain
 226                  , element "rref" $ Tree .  DTC.PlainRref Nothing <$> to <*> plain
 227                  ]
 228         tag = rule "tag" $ element "tag" text
 229         about =
 230                 (foldr ($) def <$>) $
 231                 many $ choice
 232                  [ (\a acc -> acc{DTC.titles=a:DTC.titles acc})              <$> title
 233                  , (\a acc -> (acc::DTC.About){DTC.url=Just a})              <$> attribute "url" url
 234                  , (\a acc -> acc{DTC.authors=a:DTC.authors acc})            <$> author
 235                  , (\a acc -> acc{DTC.editor=DTC.editor acc Alt.<|> Just a}) <$> editor
 236                  , (\a acc -> acc{DTC.date=DTC.date acc Alt.<|> Just a})     <$> date
 237                  , (\a acc -> acc{DTC.tags=a:DTC.tags acc})                  <$> tag
 238                  , (\a acc -> acc{DTC.links=a:DTC.links acc})                <$> link
 239                  , (\a acc -> acc{DTC.series=a:DTC.series acc})              <$> serie
 240                  , (\a acc -> acc{DTC.headers=a:DTC.headers acc})            <$> header
 241                  ]
 242         header =
 243                 rule "header" $
 244                 anyElem $ \n ->
 245                         DTC.Header (xmlNameLocal n)
 246                          <$> plain
 247         author = rule "author" $ element "author" entity
 248         editor = rule "editor" $ element "editor" entity
 249         entity = rule "entity" $
 250                 interleaved $
 251                 DTC.Entity
 252                  <$?> (def, name)
 253                  <|?> (def, attribute "street"  text)
 254                  <|?> (def, attribute "zipcode" text)
 255                  <|?> (def, attribute "city"    text)
 256                  <|?> (def, attribute "region"  text)
 257                  <|?> (def, attribute "country" text)
 258                  <|?> (def, attribute "email"   text)
 259                  <|?> (def, attribute "tel"     text)
 260                  <|?> (def, attribute "fax"     text)
 261                  <|?> (def, Just <$> attribute "url" url)
 262                  <|?> (def, Just <$> element "org" entity)
 263         serie = rule "serie" $
 264                 element "serie" $
 265                 interleaved $
 266                 DTC.Serie
 267                  <$?> (def, name)
 268                  <|?> (def, attribute "id" text)
 269         link = rule "link" $
 270                 element "link" $
 271                 interleaved $
 272                 (\n h r t p -> DTC.Link n h r t (Seq.fromList p))
 273                  <$?> (def, name)
 274                  <|?> (def, attribute "href" url)
 275                  <|?> (def, attribute "rel"  text)
 276                  <|?> (def, Just <$> attribute "type" text)
 277                  <|*> plainNode
 278         alias = rule "alias" $
 279                 element "alias" $
 280                 interleaved $
 281                 DTC.Alias
 282                  <$?> (def, id)
 283         reference = rule "reference" $
 284                 element "reference" $
 285                 DTC.Reference
 286                  <$> id
 287                  <*> about
 288
 289 instance Sym_DTC RNC.Writer where
 290         position = RNC.writeText ""
 291 instance Sym_DTC RNC.RuleWriter where
 292         position = RNC.RuleWriter position
 293
 294 -- | RNC schema for DTC
 295 schema :: [RNC.RuleWriter ()]
 296 schema =
 297  [ void $ document
 298
 299  , void $ head
 300  , void $ rule "about" $ element "about" about
 301  , void $ header
 302  , void $ tag
 303  , void $ author
 304  , void $ editor
 305  , void $ date
 306  , void $ entity
 307  , void $ link
 308  , void $ serie
 309  , void $ alias
 310
 311  , void $ body
 312  , void $ include
 313
 314  , void $ block
 315  , void $ blockToC
 316  , void $ blockToF
 317  , void $ blockIndex
 318  , void $ blockFigure
 319  , void $ blockReferences
 320  , void $ reference
 321
 322  , void $ para
 323  , void $ paraItem
 324  , void $ paraItems
 325
 326  , void $ plain
 327  , void $ plainNode
 328
 329  , void $ commonAttrs
 330  , void $ ident
 331  , void $ title
 332  , void $ name
 333  , void $ url
 334  , void $ path
 335  , void $ to
 336  , void $ id
 337  ]