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.Document (MayText(..), whenMayText)
  31 import Language.DTC.Anchor (plainifyWords)
  32 import Language.DTC.Document as DTC hiding (XML)
  33
  34 document :: Locales ls => LocaleIn ls -> Document -> XML
  35 document loc Document{..} = do
  36         let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
  37         XML.xmlModel "./schema/dtc.rnc"
  38         XML.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
  39         XML.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
  40         XML.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
  41         XML.document $ do
  42                 xmlify head
  43                 xmlify body
  44
  45 -- * Class 'Xmlify'
  46 class Xmlify a where
  47         xmlify :: a -> XML
  48
  49 instance Xmlify TL.Text where
  50         xmlify = B.toMarkup
  51 instance Xmlify Head where
  52         xmlify Head{..} =
  53                 XML.about $ xmlify about
  54 instance Xmlify (Tree BodyNode) where
  55         xmlify (Tree n ts) =
  56                 case n of
  57                  BodyBlock b -> xmlify b
  58                  BodySection{..} ->
  59                         xmlCommonAttrs attrs $
  60                         XML.section $ do
  61                                 xmlify title
  62                                 forM_ aliases xmlify
  63                                 xmlify ts
  64 instance Xmlify Block where
  65         xmlify = \case
  66          BlockPara para -> xmlify para
  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                  PlainBR       -> 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                  PlainSC       -> XML.sc   $ xmlify ts
 130                  PlainSub      -> XML.sub  $ xmlify ts
 131                  PlainSup      -> XML.sup  $ xmlify ts
 132                  PlainU        -> XML.u    $ xmlify ts
 133                  PlainEref to  -> XML.eref ! XA.to (attrify to) $ xmlify ts
 134                  PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts
 135                  PlainRef  to  -> XML.ref  ! XA.to (attrify to) $ xmlify ts
 136                  PlainRref{..} -> XML.rref ! XA.to (attrify to) $ xmlify ts
 137
 138 instance Xmlify About where
 139         xmlify About{..} = do
 140                 xmlify titles
 141                 xmlify authors
 142                 xmlify editor
 143                 xmlify date
 144                 whenMayText version $ XML.version . xmlify
 145                 forM_ keywords $ XML.keyword . xmlify
 146                 xmlify links
 147                 xmlify includes
 148 instance Xmlify Include where
 149         xmlify Include{..} =
 150                 XML.include True
 151                  ! XA.href (attrify href)
 152 instance Xmlify Date where
 153         xmlify Date{..} =
 154                 XML.date
 155                  !   XA.year (attrify year)
 156                  !?? mayAttr XA.month month
 157                  !?? mayAttr XA.day day
 158 instance Xmlify Link where
 159         xmlify Link{..} =
 160                 XML.link
 161                  !?? mayAttr XA.name name
 162                  !?? mayAttr XA.rel  rel
 163                  !?? mayAttr XA.href href
 164                  $ xmlify plain
 165 instance Xmlify Entity where
 166         xmlify Entity{..} =
 167                 XML.entity
 168                  !?? mayAttr XA.name    name
 169                  !?? mayAttr XA.street  street
 170                  !?? mayAttr XA.zipcode zipcode
 171                  !?? mayAttr XA.city    city
 172                  !?? mayAttr XA.region  region
 173                  !?? mayAttr XA.country country
 174                  !?? mayAttr XA.email   email
 175                  !?? mayAttr XA.tel     tel
 176                  !?? mayAttr XA.fax     fax
 177 instance Xmlify Title where
 178         xmlify (Title t) = XML.title $ xmlify t
 179 instance Xmlify Alias where
 180         xmlify Alias{..} = XML.alias !?? mayAttr XA.id id
 181 instance Xmlify Reference where
 182         xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
 183
 184 instance Xmlify MayText where
 185         xmlify (MayText t) = xmlify t
 186 instance Xmlify a => Xmlify (Maybe a) where
 187         xmlify = foldMap xmlify
 188 instance Xmlify a => Xmlify [a] where
 189         xmlify = foldMap xmlify
 190 instance Xmlify a => Xmlify (Seq a) where
 191         xmlify = foldMap xmlify
 192
 193 xmlId :: Ident -> B.Attribute
 194 xmlId (Ident i) = XA.id $ attrify i
 195
 196 xmlCommonAttrs :: CommonAttrs -> XML -> XML
 197 xmlCommonAttrs CommonAttrs{id=ident, ..} =
 198         (case ident of
 199          Nothing -> Fun.id
 200          Just (Ident i) ->
 201                 B.AddCustomAttribute "id" $
 202                 B.String $ TL.unpack i) .
 203         case classes of
 204          [] -> Fun.id
 205          _ ->
 206                 B.AddCustomAttribute "class" $
 207                 B.String $ TL.unpack $ TL.unwords classes