Language/DTC/Write/XML.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 module Language.DTC.Write.XML where
   4
   5 import Control.Monad (forM_, mapM_)
   6 import Data.Bool
   7 import Data.Function (($), (.))
   8 import Data.Functor ((<$>))
   9 import Data.Maybe (Maybe(..))
  10 import Data.Monoid (Monoid(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import Data.Text (Text)
  13 import Text.Blaze ((!))
  14 import Text.Blaze.Utils
  15 import Text.Blaze.XML (XML)
  16 import Data.TreeSeq.Strict (Tree(..))
  17 import qualified Data.Char as Char
  18 import qualified Data.Map.Strict as Map
  19 import qualified Data.Text as Text
  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.Document (MayText(..), whenMayText)
  27 import Language.DTC.Anchor (plainifyWords)
  28 import qualified Language.DTC.Document as DTC
  29
  30 xmlText :: Text -> XML
  31 xmlText = B.toMarkup
  32
  33 xmlDocument :: Locales ls => LocaleIn ls -> DTC.Document -> XML
  34 xmlDocument loc DTC.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                 xmlHead head
  42                 xmlBody body
  43
  44 xmlHead :: DTC.Head -> XML
  45 xmlHead DTC.Head{..} =
  46         XML.about $ xmlAbout about
  47
  48 xmlBody :: DTC.Body -> XML
  49 xmlBody = mapM_ $ \case
  50          TreeN k ts -> xmlBodyKey k $ xmlBody ts
  51          Tree0 v -> xmlBodyValue v
  52
  53 xmlBodyKey :: DTC.BodyKey -> XML -> XML
  54 xmlBodyKey k body = case k of
  55          DTC.Section{..} ->
  56                 xmlCommonAttrs attrs $
  57                 XML.section $ do
  58                         xmlTitle title
  59                         forM_ aliases xmlAlias
  60                         body
  61
  62 xmlBodyValue :: DTC.BodyValue -> XML
  63 xmlBodyValue = \case
  64          DTC.ToC{..} ->
  65                 xmlCommonAttrs attrs $
  66                 XML.toc
  67                  !?? mayAttr XA.depth depth
  68          DTC.ToF{..} ->
  69                 xmlCommonAttrs attrs $
  70                 XML.tof $
  71                         XML.ul $
  72                                 forM_ types $
  73                                         XML.li . xmlText
  74          DTC.Figure{..} ->
  75                 xmlCommonAttrs attrs $
  76                 XML.figure
  77                  ! XA.type_ (attrValue type_) $ do
  78                         xmlTitle title
  79                         xmlBlocks blocks
  80          DTC.Index{..} ->
  81                 xmlCommonAttrs attrs $
  82                 XML.index $ do
  83                         XML.ul $
  84                                 forM_ terms $ \aliases ->
  85                                         XML.li $
  86                                                 xmlText $
  87                                                 Text.unlines $
  88                                                 plainifyWords <$> aliases
  89          DTC.Block v -> xmlBlock v
  90
  91 xmlAbout :: DTC.About -> XML
  92 xmlAbout DTC.About{..} = do
  93         forM_ titles   $ xmlTitle
  94         forM_ authors  $ xmlAuthor
  95         forM_ editor   $ xmlEditor
  96         forM_ date     $ xmlDate
  97         whenMayText version xmlVersion
  98         forM_ keywords $ xmlKeyword
  99         forM_ links    $ xmlLink
 100         forM_ includes $ xmlInclude
 101
 102 xmlInclude :: DTC.Include -> XML
 103 xmlInclude DTC.Include{..} =
 104         XML.include True
 105          ! XA.href (attrValue href)
 106
 107 xmlKeyword :: Text -> XML
 108 xmlKeyword = XML.keyword . xmlText
 109
 110 xmlVersion :: MayText -> XML
 111 xmlVersion (MayText t) = XML.version $ xmlText t
 112
 113 xmlDate :: DTC.Date -> XML
 114 xmlDate DTC.Date{..} =
 115         XML.date
 116          !   XA.year (attrValue year)
 117          !?? mayAttr XA.month month
 118          !?? mayAttr XA.day day
 119
 120 xmlLink :: DTC.Link -> XML
 121 xmlLink DTC.Link{..} =
 122         XML.link
 123          !?? mayAttr XA.name name
 124          !?? mayAttr XA.rel  rel
 125          !?? mayAttr XA.href href
 126          $ xmlPara para
 127
 128 xmlAddress :: DTC.Address -> XML
 129 xmlAddress DTC.Address{..} =
 130         XML.address
 131          !?? mayAttr XA.street street
 132          !?? mayAttr XA.zipcode zipcode
 133          !?? mayAttr XA.city    city
 134          !?? mayAttr XA.region  region
 135          !?? mayAttr XA.country country
 136          !?? mayAttr XA.email   email
 137          !?? mayAttr XA.tel     tel
 138          !?? mayAttr XA.fax     fax
 139
 140 xmlAuthor :: DTC.Entity -> XML
 141 xmlAuthor DTC.Entity{..} =
 142         XML.author
 143          !?? mayAttr XA.name name
 144          $ xmlAddress address
 145
 146 xmlEditor :: DTC.Entity -> XML
 147 xmlEditor DTC.Entity{..} =
 148         XML.editor
 149          !?? mayAttr XA.name name
 150          $ xmlAddress address
 151
 152 xmlTitle :: DTC.Title -> XML
 153 xmlTitle (DTC.Title t) = XML.title $ xmlPara t
 154
 155 xmlAlias :: DTC.Alias -> XML
 156 xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
 157
 158 xmlId :: DTC.Ident -> B.Attribute
 159 xmlId (DTC.Ident i) = XA.id $ attrValue i
 160
 161 xmlBlocks :: DTC.Blocks -> XML
 162 xmlBlocks = (`forM_` xmlBlock)
 163
 164 xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
 165 xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
 166         (case ident of
 167          Nothing -> \m -> m
 168          Just (DTC.Ident i)  -> B.AddCustomAttribute "id" (B.Text i)) .
 169         case classes of
 170          [] -> \m -> m
 171          _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords classes)
 172
 173 xmlBlock :: DTC.Block -> XML
 174 xmlBlock = \case
 175          DTC.Para{..} ->
 176                 xmlCommonAttrs attrs $
 177                 XML.para $ xmlPara para
 178          DTC.OL{..} ->
 179                 xmlCommonAttrs attrs $
 180                 XML.ol $ forM_ items $ XML.li . xmlBlocks
 181          DTC.UL{..} ->
 182                 xmlCommonAttrs attrs $
 183                 XML.ul $ forM_ items $ XML.li . xmlBlocks
 184          DTC.RL{..} ->
 185                 xmlCommonAttrs attrs $
 186                 XML.rl $ forM_ refs $ xmlReference
 187          -- DTC.Index -> XML.index
 188          DTC.Comment c ->
 189                 XML.comment c
 190          DTC.Artwork{..} ->
 191                 xmlCommonAttrs attrs $
 192                 XML.artwork mempty
 193
 194 xmlPara :: DTC.Para -> XML
 195 xmlPara = (`forM_` xmlLine)
 196
 197 xmlLine :: Tree DTC.LineKey DTC.LineValue -> XML
 198 xmlLine = \case
 199  Tree0 v ->
 200         case v of
 201          DTC.Plain p -> B.toMarkup p
 202          DTC.BR      -> XML.br
 203  TreeN k ls ->
 204         case k of
 205          DTC.B        -> XML.b    $ xmlPara ls
 206          DTC.Code     -> XML.code $ xmlPara ls
 207          DTC.Del      -> XML.del  $ xmlPara ls
 208          DTC.I        -> XML.i    $ xmlPara ls
 209          DTC.Note     -> XML.note $ xmlPara ls
 210          DTC.Q        -> XML.q    $ xmlPara ls
 211          DTC.SC       -> XML.sc   $ xmlPara ls
 212          DTC.Sub      -> XML.sub  $ xmlPara ls
 213          DTC.Sup      -> XML.sup  $ xmlPara ls
 214          DTC.U        -> XML.u    $ xmlPara ls
 215          DTC.Eref to  -> XML.eref ! XA.to (attrValue to) $ xmlPara ls
 216          DTC.Iref{..} -> XML.iref ! XA.term (attrValue $ plainifyWords term) $ xmlPara ls
 217          DTC.Ref  to  -> XML.ref  ! XA.to (attrValue to) $ xmlPara ls
 218          DTC.Rref to  -> XML.rref ! XA.to (attrValue to) $ xmlPara ls
 219
 220 xmlReference :: DTC.Reference -> XML
 221 xmlReference DTC.Reference{..} =
 222         XML.reference mempty