Language/DTC/Write/XML.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Language.DTC.Write.XML where
   5
   6 import Control.Monad (forM_)
   7 import Data.Bool
   8 import Data.Foldable (Foldable(..))
   9 import Data.Function (($), (.))
  10 import Data.Functor ((<$>))
  11 import Data.Maybe (Maybe(..))
  12 import Data.Monoid (Monoid(..))
  13 import Data.Sequence (Seq)
  14 import Data.TreeSeq.Strict (Tree(..))
  15 import Text.Blaze ((!))
  16 import Text.Blaze.Utils
  17 import Text.Blaze.XML (XML)
  18 import qualified Data.Function as Fun
  19 import qualified Data.Text.Lazy as TL
  20 import qualified Text.Blaze as B
  21 import qualified Text.Blaze.DTC as XML
  22 import qualified Text.Blaze.DTC.Attributes as XA
  23 import qualified Text.Blaze.Internal as B
  24
  25 import Data.Locale
  26 import Language.DTC.Anchor (plainifyWords)
  27 import Language.DTC.Document as DTC hiding (XML)
  28
  29 writeXML :: Locales ls => LocaleIn ls -> Document -> XML
  30 writeXML _loc Document{..} = do
  31         XML.xmlModel "./schema/dtc.rnc"
  32         {-
  33         let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
  34         XML.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
  35         XML.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
  36         XML.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
  37         -}
  38         XML.document $ do
  39                 xmlify head
  40                 xmlify body
  41
  42 -- * Class 'Xmlify'
  43 class Xmlify a where
  44         xmlify :: a -> XML
  45
  46 instance Xmlify TL.Text where
  47         xmlify = B.toMarkup
  48 instance Xmlify Head where
  49         xmlify Head{..} =
  50                 xmlify about
  51 instance Xmlify (Tree BodyNode) where
  52         xmlify (Tree n ts) =
  53                 case n of
  54                  BodyBlock b -> xmlify b
  55                  BodySection{..} ->
  56                         xmlCommonAttrs attrs $
  57                         XML.section $ do
  58                                 xmlify title
  59                                 forM_ aliases xmlify
  60                                 xmlify ts
  61 instance Xmlify Block where
  62         xmlify = \case
  63          BlockPara para -> xmlify para
  64          BlockBreak{..} ->
  65                 xmlCommonAttrs attrs $
  66                 XML.break
  67          BlockToC{..} ->
  68                 xmlCommonAttrs attrs $
  69                 XML.toc
  70                  !?? mayAttr XA.depth depth
  71          BlockToF{..} ->
  72                 xmlCommonAttrs attrs $
  73                 XML.tof $
  74                         XML.ul $
  75                                 forM_ types $
  76                                         XML.li . xmlify
  77          BlockIndex{..} ->
  78                 xmlCommonAttrs attrs $
  79                 XML.index $ do
  80                         XML.ul $
  81                                 forM_ terms $ \aliases ->
  82                                         XML.li $
  83                                                 xmlify $
  84                                                 TL.unlines $
  85                                                 plainifyWords <$> aliases
  86          BlockFigure{..} ->
  87                 xmlCommonAttrs attrs $
  88                 XML.figure
  89                  ! XA.type_ (attrify type_) $ do
  90                         xmlify mayTitle
  91                         xmlify paras
  92          BlockReferences{..} ->
  93                 xmlCommonAttrs attrs $
  94                 XML.references $ xmlify refs
  95 instance Xmlify Para where
  96         xmlify = \case
  97          ParaItem{..}  -> xmlify item
  98          ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items
  99 instance Xmlify ParaItem where
 100         xmlify = \case
 101          ParaPlain p -> XML.p $ xmlify p
 102          ParaComment c ->
 103                 XML.comment $ TL.toStrict c
 104          ParaArtwork{..} ->
 105                 XML.artwork
 106                  ! XA.type_ (attrify type_) $ do
 107                         xmlify text
 108          ParaQuote{..} ->
 109                 XML.quote
 110                  ! XA.type_ (attrify type_) $ do
 111                         xmlify paras
 112          ParaOL items -> XML.ol $ forM_ items xmlify
 113          ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify
 114 instance Xmlify ListItem where
 115         xmlify ListItem{..} =
 116                 XML.li ! XA.name (attrify name) $ xmlify paras
 117 instance Xmlify (Tree PlainNode) where
 118         xmlify (Tree n ts) =
 119                 case n of
 120                  PlainText t   -> xmlify t
 121                  PlainBreak    -> XML.br
 122                  PlainGroup    -> xmlify ts
 123                  PlainB        -> XML.b    $ xmlify ts
 124                  PlainCode     -> XML.code $ xmlify ts
 125                  PlainDel      -> XML.del  $ xmlify ts
 126                  PlainI        -> XML.i    $ xmlify ts
 127                  PlainNote{..} -> XML.note $ xmlify note
 128                  PlainQ        -> XML.q    $ xmlify ts
 129                  PlainSpan{..} -> xmlCommonAttrs attrs $ XML.span $ xmlify ts
 130                  PlainSC       -> XML.sc   $ xmlify ts
 131                  PlainSub      -> XML.sub  $ xmlify ts
 132                  PlainSup      -> XML.sup  $ xmlify ts
 133                  PlainU        -> XML.u    $ xmlify ts
 134                  PlainEref to  -> XML.eref ! XA.to (attrify to) $ xmlify ts
 135                  PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts
 136                  PlainRef  to  -> XML.ref  ! XA.to (attrify $ unIdent to) $ xmlify ts
 137                  PlainRref{..} -> XML.rref ! XA.to (attrify $ unIdent to) $ xmlify ts
 138
 139 instance Xmlify About where
 140         xmlify About{..} = do
 141                 XML.about
 142                  !?? mayAttr XA.url url
 143                  $ do
 144                         xmlify titles
 145                         xmlify authors
 146                         xmlify editor
 147                         xmlify date
 148                         forM_ tags $ XML.tag . xmlify
 149                         xmlify links
 150                         xmlify includes
 151 instance Xmlify Include where
 152         xmlify Include{..} =
 153                 XML.include True
 154                  ! XA.href (attrify href)
 155 instance Xmlify Date where
 156         xmlify Date{..} =
 157                 XML.date
 158                  !   XA.year (attrify year)
 159                  !?? mayAttr XA.month month
 160                  !?? mayAttr XA.day day
 161 instance Xmlify Link where
 162         xmlify Link{..} =
 163                 XML.link
 164                  !?? mayAttr XA.name name
 165                  !?? mayAttr XA.rel  rel
 166                  !?? mayAttr XA.href href
 167                  $ xmlify plain
 168 instance Xmlify Entity where
 169         xmlify Entity{..} =
 170                 XML.entity
 171                  !?? mayAttr XA.name    name
 172                  !?? mayAttr XA.street  street
 173                  !?? mayAttr XA.zipcode zipcode
 174                  !?? mayAttr XA.city    city
 175                  !?? mayAttr XA.region  region
 176                  !?? mayAttr XA.country country
 177                  !?? mayAttr XA.email   email
 178                  !?? mayAttr XA.tel     tel
 179                  !?? mayAttr XA.fax     fax
 180 instance Xmlify Title where
 181         xmlify (Title t) = XML.title $ xmlify t
 182 instance Xmlify Alias where
 183         xmlify Alias{..} = XML.alias !?? mayAttr XA.id id
 184 instance Xmlify Reference where
 185         xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
 186
 187 instance Xmlify a => Xmlify (Maybe a) where
 188         xmlify = foldMap xmlify
 189 instance Xmlify a => Xmlify [a] where
 190         xmlify = foldMap xmlify
 191 instance Xmlify a => Xmlify (Seq a) where
 192         xmlify = foldMap xmlify
 193
 194 xmlId :: Ident -> B.Attribute
 195 xmlId (Ident i) = XA.id $ attrify i
 196
 197 xmlCommonAttrs :: CommonAttrs -> XML -> XML
 198 xmlCommonAttrs CommonAttrs{id=ident, ..} =
 199         (case ident of
 200          Nothing -> Fun.id
 201          Just (Ident i) ->
 202                 B.AddCustomAttribute "id" $
 203                 B.String $ TL.unpack i) .
 204         case classes of
 205          [] -> Fun.id
 206          _ ->
 207                 B.AddCustomAttribute "class" $
 208                 B.String $ TL.unpack $ TL.unwords classes