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