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