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