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          BlockToC{..} ->
  65                 xmlCommonAttrs attrs $
  66                 XML.toc
  67                  !?? mayAttr XA.depth depth
  68          BlockToF{..} ->
  69                 xmlCommonAttrs attrs $
  70                 XML.tof $
  71                         XML.ul $
  72                                 forM_ types $
  73                                         XML.li . xmlify
  74          BlockIndex{..} ->
  75                 xmlCommonAttrs attrs $
  76                 XML.index $ do
  77                         XML.ul $
  78                                 forM_ terms $ \aliases ->
  79                                         XML.li $
  80                                                 xmlify $
  81                                                 TL.unlines $
  82                                                 plainifyWords <$> aliases
  83          BlockFigure{..} ->
  84                 xmlCommonAttrs attrs $
  85                 XML.figure
  86                  ! XA.type_ (attrify type_) $ do
  87                         xmlify mayTitle
  88                         xmlify paras
  89          BlockReferences{..} ->
  90                 xmlCommonAttrs attrs $
  91                 XML.references $ xmlify refs
  92 instance Xmlify Para where
  93         xmlify = \case
  94          ParaItem{..}  -> xmlify item
  95          ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items
  96 instance Xmlify ParaItem where
  97         xmlify = \case
  98          ParaPlain p -> XML.p $ xmlify p
  99          ParaComment c ->
 100                 XML.comment $ TL.toStrict c
 101          ParaArtwork{..} ->
 102                 XML.artwork
 103                  ! XA.type_ (attrify type_) $ do
 104                         xmlify text
 105          ParaQuote{..} ->
 106                 XML.quote
 107                  ! XA.type_ (attrify type_) $ do
 108                         xmlify paras
 109          ParaOL items -> XML.ol $ forM_ items xmlify
 110          ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify
 111 instance Xmlify ListItem where
 112         xmlify ListItem{..} =
 113                 XML.li ! XA.name (attrify name) $ xmlify paras
 114 instance Xmlify (Tree PlainNode) where
 115         xmlify (Tree n ts) =
 116                 case n of
 117                  PlainText t   -> xmlify t
 118                  PlainBR       -> XML.br
 119                  PlainGroup    -> xmlify ts
 120                  PlainB        -> XML.b    $ xmlify ts
 121                  PlainCode     -> XML.code $ xmlify ts
 122                  PlainDel      -> XML.del  $ xmlify ts
 123                  PlainI        -> XML.i    $ xmlify ts
 124                  PlainNote{..} -> XML.note $ xmlify note
 125                  PlainQ        -> XML.q    $ xmlify ts
 126                  PlainSC       -> XML.sc   $ xmlify ts
 127                  PlainSub      -> XML.sub  $ xmlify ts
 128                  PlainSup      -> XML.sup  $ xmlify ts
 129                  PlainU        -> XML.u    $ xmlify ts
 130                  PlainEref to  -> XML.eref ! XA.to (attrify to) $ xmlify ts
 131                  PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts
 132                  PlainRef  to  -> XML.ref  ! XA.to (attrify to) $ xmlify ts
 133                  PlainRref{..} -> XML.rref ! XA.to (attrify to) $ xmlify ts
 134
 135 instance Xmlify About where
 136         xmlify About{..} = do
 137                 XML.about
 138                  !?? mayAttr XA.url url
 139                  $ do
 140                         xmlify titles
 141                         xmlify authors
 142                         xmlify editor
 143                         xmlify date
 144                         forM_ tags $ XML.tag . xmlify
 145                         xmlify links
 146                         xmlify includes
 147 instance Xmlify Include where
 148         xmlify Include{..} =
 149                 XML.include True
 150                  ! XA.href (attrify href)
 151 instance Xmlify Date where
 152         xmlify Date{..} =
 153                 XML.date
 154                  !   XA.year (attrify year)
 155                  !?? mayAttr XA.month month
 156                  !?? mayAttr XA.day day
 157 instance Xmlify Link where
 158         xmlify Link{..} =
 159                 XML.link
 160                  !?? mayAttr XA.name name
 161                  !?? mayAttr XA.rel  rel
 162                  !?? mayAttr XA.href href
 163                  $ xmlify plain
 164 instance Xmlify Entity where
 165         xmlify Entity{..} =
 166                 XML.entity
 167                  !?? mayAttr XA.name    name
 168                  !?? mayAttr XA.street  street
 169                  !?? mayAttr XA.zipcode zipcode
 170                  !?? mayAttr XA.city    city
 171                  !?? mayAttr XA.region  region
 172                  !?? mayAttr XA.country country
 173                  !?? mayAttr XA.email   email
 174                  !?? mayAttr XA.tel     tel
 175                  !?? mayAttr XA.fax     fax
 176 instance Xmlify Title where
 177         xmlify (Title t) = XML.title $ xmlify t
 178 instance Xmlify Alias where
 179         xmlify Alias{..} = XML.alias !?? mayAttr XA.id id
 180 instance Xmlify Reference where
 181         xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
 182
 183 instance Xmlify a => Xmlify (Maybe a) where
 184         xmlify = foldMap xmlify
 185 instance Xmlify a => Xmlify [a] where
 186         xmlify = foldMap xmlify
 187 instance Xmlify a => Xmlify (Seq a) where
 188         xmlify = foldMap xmlify
 189
 190 xmlId :: Ident -> B.Attribute
 191 xmlId (Ident i) = XA.id $ attrify i
 192
 193 xmlCommonAttrs :: CommonAttrs -> XML -> XML
 194 xmlCommonAttrs CommonAttrs{id=ident, ..} =
 195         (case ident of
 196          Nothing -> Fun.id
 197          Just (Ident i) ->
 198                 B.AddCustomAttribute "id" $
 199                 B.String $ TL.unpack i) .
 200         case classes of
 201          [] -> Fun.id
 202          _ ->
 203                 B.AddCustomAttribute "class" $
 204                 B.String $ TL.unpack $ TL.unwords classes