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 $ XML.li . xmlify
 113          ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify
 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                 xmlify titles
 138                 xmlify authors
 139                 xmlify editor
 140                 xmlify date
 141                 whenMayText version $ XML.version . xmlify
 142                 forM_ keywords $ XML.keyword . xmlify
 143                 xmlify links
 144                 xmlify includes
 145 instance Xmlify Include where
 146         xmlify Include{..} =
 147                 XML.include True
 148                  ! XA.href (attrify href)
 149 instance Xmlify Date where
 150         xmlify Date{..} =
 151                 XML.date
 152                  !   XA.year (attrify year)
 153                  !?? mayAttr XA.month month
 154                  !?? mayAttr XA.day day
 155 instance Xmlify Link where
 156         xmlify Link{..} =
 157                 XML.link
 158                  !?? mayAttr XA.name name
 159                  !?? mayAttr XA.rel  rel
 160                  !?? mayAttr XA.href href
 161                  $ xmlify plain
 162 instance Xmlify Entity where
 163         xmlify Entity{..} =
 164                 XML.entity
 165                  !?? mayAttr XA.name    name
 166                  !?? mayAttr XA.street  street
 167                  !?? mayAttr XA.zipcode zipcode
 168                  !?? mayAttr XA.city    city
 169                  !?? mayAttr XA.region  region
 170                  !?? mayAttr XA.country country
 171                  !?? mayAttr XA.email   email
 172                  !?? mayAttr XA.tel     tel
 173                  !?? mayAttr XA.fax     fax
 174 instance Xmlify Title where
 175         xmlify (Title t) = XML.title $ xmlify t
 176 instance Xmlify Alias where
 177         xmlify Alias{..} = XML.alias !?? mayAttr XA.id id
 178 instance Xmlify Reference where
 179         xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
 180
 181 instance Xmlify MayText where
 182         xmlify (MayText t) = xmlify t
 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