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.Index{..} ->
  75                 xmlCommonAttrs attrs $
  76                 XML.index $ do
  77                         XML.ul $
  78                                 forM_ terms $ \aliases ->
  79                                         XML.li $
  80                                                 xmlText $
  81                                                 Text.unlines $
  82                                                 plainifyWords <$> aliases
  83          DTC.Figure{..} ->
  84                 xmlCommonAttrs attrs $
  85                 XML.figure
  86                  ! XA.type_ (attrify type_) $ do
  87                         xmlTitle title
  88                         xmlBlocks blocks
  89          DTC.References{..} ->
  90                 xmlCommonAttrs attrs $
  91                 XML.references $ forM_ refs $ xmlReference
  92          DTC.Block v -> xmlBlock v
  93
  94 xmlAbout :: DTC.About -> XML
  95 xmlAbout DTC.About{..} = do
  96         forM_ titles   $ xmlTitle
  97         forM_ authors  $ xmlEntity
  98         forM_ editor   $ xmlEntity
  99         forM_ date     $ xmlDate
 100         whenMayText version xmlVersion
 101         forM_ keywords $ xmlKeyword
 102         forM_ links    $ xmlLink
 103         forM_ includes $ xmlInclude
 104
 105 xmlInclude :: DTC.Include -> XML
 106 xmlInclude DTC.Include{..} =
 107         XML.include True
 108          ! XA.href (attrify href)
 109
 110 xmlKeyword :: Text -> XML
 111 xmlKeyword = XML.keyword . xmlText
 112
 113 xmlVersion :: MayText -> XML
 114 xmlVersion (MayText t) = XML.version $ xmlText t
 115
 116 xmlDate :: DTC.Date -> XML
 117 xmlDate DTC.Date{..} =
 118         XML.date
 119          !   XA.year (attrify year)
 120          !?? mayAttr XA.month month
 121          !?? mayAttr XA.day day
 122
 123 xmlLink :: DTC.Link -> XML
 124 xmlLink DTC.Link{..} =
 125         XML.link
 126          !?? mayAttr XA.name name
 127          !?? mayAttr XA.rel  rel
 128          !?? mayAttr XA.href href
 129          $ xmlPara para
 130
 131 xmlEntity :: DTC.Entity -> XML
 132 xmlEntity DTC.Entity{..} =
 133         XML.entity
 134          !?? mayAttr XA.name    name
 135          !?? mayAttr XA.street  street
 136          !?? mayAttr XA.zipcode zipcode
 137          !?? mayAttr XA.city    city
 138          !?? mayAttr XA.region  region
 139          !?? mayAttr XA.country country
 140          !?? mayAttr XA.email   email
 141          !?? mayAttr XA.tel     tel
 142          !?? mayAttr XA.fax     fax
 143
 144 xmlTitle :: DTC.Title -> XML
 145 xmlTitle (DTC.Title t) = XML.title $ xmlPara t
 146
 147 xmlAlias :: DTC.Alias -> XML
 148 xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
 149
 150 xmlId :: DTC.Ident -> B.Attribute
 151 xmlId (DTC.Ident i) = XA.id $ attrify i
 152
 153 xmlBlocks :: DTC.Blocks -> XML
 154 xmlBlocks = (`forM_` xmlBlock)
 155
 156 xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
 157 xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
 158         (case ident of
 159          Nothing -> \m -> m
 160          Just (DTC.Ident i)  -> B.AddCustomAttribute "id" (B.Text i)) .
 161         case classes of
 162          [] -> \m -> m
 163          _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords classes)
 164
 165 xmlBlock :: DTC.Block -> XML
 166 xmlBlock = \case
 167          DTC.Para{..} ->
 168                 xmlCommonAttrs attrs $
 169                 XML.para $ xmlPara para
 170          DTC.OL{..} ->
 171                 xmlCommonAttrs attrs $
 172                 XML.ol $ forM_ items $ XML.li . xmlBlocks
 173          DTC.UL{..} ->
 174                 xmlCommonAttrs attrs $
 175                 XML.ul $ forM_ items $ XML.li . xmlBlocks
 176          DTC.Comment c ->
 177                 XML.comment c
 178          DTC.Artwork{..} ->
 179                 xmlCommonAttrs attrs $
 180                 XML.artwork mempty
 181
 182 xmlPara :: DTC.Para -> XML
 183 xmlPara = (`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    $ xmlPara ls
 194          DTC.Code     -> XML.code $ xmlPara ls
 195          DTC.Del      -> XML.del  $ xmlPara ls
 196          DTC.I        -> XML.i    $ xmlPara ls
 197          DTC.Note     -> XML.note $ xmlPara ls
 198          DTC.Q        -> XML.q    $ xmlPara ls
 199          DTC.SC       -> XML.sc   $ xmlPara ls
 200          DTC.Sub      -> XML.sub  $ xmlPara ls
 201          DTC.Sup      -> XML.sup  $ xmlPara ls
 202          DTC.U        -> XML.u    $ xmlPara ls
 203          DTC.Eref to  -> XML.eref ! XA.to (attrify to) $ xmlPara ls
 204          DTC.Iref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlPara ls
 205          DTC.Ref  to  -> XML.ref  ! XA.to (attrify to) $ xmlPara ls
 206          DTC.Rref{..} -> XML.rref ! XA.to (attrify to) $ xmlPara ls
 207
 208 xmlReference :: DTC.Reference -> XML
 209 xmlReference DTC.Reference{..} =
 210         XML.reference mempty