Language/DTC/Write/XML.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 module Language.DTC.Write.XML where
   4
   5 -- import Data.Foldable (Foldable(..))
   6 import Control.Monad (forM_, mapM_)
   7 import Data.Bool
   8 import Data.Function (($), (.))
   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 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                         xmlVerticals verts
  77          DTC.Vertical v -> xmlVertical 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          $ xmlHorizontals body
 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 $ xmlHorizontals 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 xmlVerticals :: DTC.Verticals -> XML
 150 xmlVerticals = (`forM_` xmlVertical)
 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 xmlVertical :: DTC.Vertical -> XML
 162 xmlVertical = \case
 163          DTC.Para{..} ->
 164                 xmlCommonAttrs attrs $
 165                 XML.para $ xmlHorizontals horis
 166          DTC.OL{..} ->
 167                 xmlCommonAttrs attrs $
 168                 XML.ol $ forM_ items $ XML.li . xmlVerticals
 169          DTC.UL{..} ->
 170                 xmlCommonAttrs attrs $
 171                 XML.ul $ forM_ items $ XML.li . xmlVerticals
 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 xmlHorizontals :: DTC.Horizontals -> XML
 183 xmlHorizontals = (`forM_` xmlHorizontal)
 184
 185 xmlHorizontal :: DTC.Horizontal -> XML
 186 xmlHorizontal = \case
 187  DTC.Plain txt  -> B.toMarkup txt
 188  DTC.BR         -> XML.br
 189  DTC.B    hs    -> XML.b    $ xmlHorizontals hs
 190  DTC.Code hs    -> XML.code $ xmlHorizontals hs
 191  DTC.Del  hs    -> XML.del  $ xmlHorizontals hs
 192  DTC.I    hs    -> XML.i    $ xmlHorizontals hs
 193  DTC.Note hs    -> XML.note $ xmlHorizontals hs
 194  DTC.Q    hs    -> XML.q    $ xmlHorizontals hs
 195  DTC.SC   hs    -> XML.sc   $ xmlHorizontals hs
 196  DTC.Sub  hs    -> XML.sub  $ xmlHorizontals hs
 197  DTC.Sup  hs    -> XML.sup  $ xmlHorizontals hs
 198  DTC.Eref to hs -> XML.eref ! XA.to (attrValue to) $ xmlHorizontals hs
 199  DTC.Iref{..}   -> XML.iref ! XA.term (attrValue term) $ xmlHorizontals text
 200  DTC.Ref  to hs -> XML.ref  ! XA.to (attrValue to) $ xmlHorizontals hs
 201  DTC.Rref to hs -> XML.rref ! XA.to (attrValue to) $ xmlHorizontals hs
 202
 203 xmlReference :: DTC.Reference -> XML
 204 xmlReference DTC.Reference{..} =
 205         XML.reference mempty