Language/DTC/Write/XML.hs

   1 {-# LANGUAGE RecordWildCards #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Language.DTC.Write.XML where
   5
   6 -- import Data.Foldable (Foldable(..))
   7 import Control.Monad (forM_, mapM_)
   8 import Data.Bool
   9 import Data.Function (($), (.))
  10 import Data.Maybe (Maybe(..))
  11 import Data.Monoid (Monoid(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.Text (Text)
  14 import Text.Blaze ((!))
  15 import Text.Blaze.Utils
  16 import Text.Blaze.XML (XML)
  17 import Data.TreeSeq.Strict (Tree(..))
  18 import qualified Data.Char as Char
  19 import qualified Data.Map.Strict as Map
  20 import qualified Data.Text as Text
  21 import qualified Text.Blaze as B
  22 import qualified Text.Blaze.DTC as XML
  23 import qualified Text.Blaze.DTC.Attributes as XA
  24 import qualified Text.Blaze.Internal as B
  25
  26 import Data.Locale
  27 import Language.DTC.Document (MayText(..), whenMayText)
  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 vs -> xmlBodyValue `mapM_` vs
  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                  !?? mayAttr XA.depth depth
  72          DTC.Figure{..} ->
  73                 xmlCommonAttrs attrs $
  74                 XML.figure
  75                  ! XA.type_ (attrValue type_) $ do
  76                         xmlTitle title
  77                         xmlVerticals verts
  78          DTC.Vertical v -> xmlVertical v
  79
  80 xmlAbout :: DTC.About -> XML
  81 xmlAbout DTC.About{..} = do
  82         forM_ titles   $ xmlTitle
  83         forM_ authors  $ xmlAuthor
  84         forM_ editor   $ xmlEditor
  85         forM_ date     $ xmlDate
  86         whenMayText version xmlVersion
  87         forM_ keywords $ xmlKeyword
  88         forM_ links    $ xmlLink
  89         forM_ includes $ xmlInclude
  90
  91 xmlInclude :: DTC.Include -> XML
  92 xmlInclude DTC.Include{..} =
  93         XML.include True
  94          ! XA.href (attrValue href)
  95
  96 xmlKeyword :: Text -> XML
  97 xmlKeyword = XML.keyword . xmlText
  98
  99 xmlVersion :: MayText -> XML
 100 xmlVersion (MayText t) = XML.version $ xmlText t
 101
 102 xmlDate :: DTC.Date -> XML
 103 xmlDate DTC.Date{..} =
 104         XML.date
 105          !   XA.year (attrValue year)
 106          !?? mayAttr XA.month month
 107          !?? mayAttr XA.day day
 108
 109 xmlLink :: DTC.Link -> XML
 110 xmlLink DTC.Link{..} =
 111         XML.link
 112          !?? mayAttr XA.name name
 113          !?? mayAttr XA.rel  rel
 114          !?? mayAttr XA.href href
 115          $ xmlHorizontals body
 116
 117 xmlAddress :: DTC.Address -> XML
 118 xmlAddress DTC.Address{..} =
 119         XML.address
 120          !?? mayAttr XA.street street
 121          !?? mayAttr XA.zipcode zipcode
 122          !?? mayAttr XA.city    city
 123          !?? mayAttr XA.region  region
 124          !?? mayAttr XA.country country
 125          !?? mayAttr XA.email   email
 126          !?? mayAttr XA.tel     tel
 127          !?? mayAttr XA.fax     fax
 128
 129 xmlAuthor :: DTC.Entity -> XML
 130 xmlAuthor DTC.Entity{..} =
 131         XML.author
 132          !?? mayAttr XA.name name
 133          $ xmlAddress address
 134
 135 xmlEditor :: DTC.Entity -> XML
 136 xmlEditor DTC.Entity{..} =
 137         XML.editor
 138          !?? mayAttr XA.name name
 139          $ xmlAddress address
 140
 141 xmlTitle :: DTC.Title -> XML
 142 xmlTitle (DTC.Title t) = XML.title $ xmlHorizontals t
 143
 144 xmlAlias :: DTC.Alias -> XML
 145 xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
 146
 147 xmlId :: DTC.Ident -> B.Attribute
 148 xmlId (DTC.Ident i) = XA.id $ attrValue i
 149
 150 xmlVerticals :: DTC.Verticals -> XML
 151 xmlVerticals = (`forM_` xmlVertical)
 152
 153 xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
 154 xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
 155         (case ident of
 156          Nothing -> \m -> m
 157          Just (DTC.Ident i)  -> B.AddCustomAttribute "id" (B.Text i)) .
 158         case classes of
 159          [] -> \m -> m
 160          _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords classes)
 161
 162 xmlVertical :: DTC.Vertical -> XML
 163 xmlVertical = \case
 164          DTC.Para{..} ->
 165                 xmlCommonAttrs attrs $
 166                 XML.para $ xmlHorizontals horis
 167          DTC.OL{..} ->
 168                 xmlCommonAttrs attrs $
 169                 XML.ol $ forM_ items $ XML.li . xmlVerticals
 170          DTC.UL{..} ->
 171                 xmlCommonAttrs attrs $
 172                 XML.ul $ forM_ items $ XML.li . xmlVerticals
 173          DTC.RL{..} ->
 174                 xmlCommonAttrs attrs $
 175                 XML.rl $ forM_ refs $ xmlReference
 176          -- DTC.Index -> XML.index
 177          DTC.Comment c ->
 178                 XML.comment c
 179          DTC.Artwork{..} ->
 180                 xmlCommonAttrs attrs $
 181                 XML.artwork mempty
 182
 183 xmlHorizontals :: DTC.Horizontals -> XML
 184 xmlHorizontals = (`forM_` xmlHorizontal)
 185
 186 xmlHorizontal :: DTC.Horizontal -> XML
 187 xmlHorizontal = \case
 188  DTC.Plain txt -> B.toMarkup txt
 189  DTC.BR -> XML.br
 190  DTC.B       hs -> XML.b    $ xmlHorizontals hs
 191  DTC.Code    hs -> XML.code $ xmlHorizontals hs
 192  DTC.Del     hs -> XML.del  $ xmlHorizontals hs
 193  DTC.I       hs -> XML.i    $ xmlHorizontals hs
 194  DTC.Note    hs -> XML.note $ xmlHorizontals hs
 195  DTC.Q       hs -> XML.q    $ xmlHorizontals hs
 196  DTC.SC      hs -> XML.sc   $ xmlHorizontals hs
 197  DTC.Sub     hs -> XML.sub  $ xmlHorizontals hs
 198  DTC.Sup     hs -> XML.sup  $ xmlHorizontals hs
 199  DTC.Eref to hs -> XML.eref ! XA.to (attrValue to) $ xmlHorizontals hs
 200  DTC.Iref to hs -> XML.iref ! XA.to (attrValue to) $ xmlHorizontals hs
 201  DTC.Ref  to hs -> XML.ref  ! XA.to (attrValue to) $ xmlHorizontals hs
 202  DTC.Rref to hs -> XML.rref ! XA.to (attrValue to) $ xmlHorizontals hs
 203
 204 xmlReference :: DTC.Reference -> XML
 205 xmlReference DTC.Reference{..} =
 206         XML.reference mempty