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 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          DTC.Verticals vs -> xmlVerticals vs
  50          DTC.Section{..} ->
  51                 xmlCommonAttrs attrs $
  52                 XML.section $ do
  53                         xmlTitle title
  54                         forM_ aliases xmlAlias
  55                         xmlBody body
  56          DTC.ToC{..} ->
  57                 xmlCommonAttrs attrs $
  58                 XML.toc
  59                  !?? mayAttr XA.depth depth
  60          DTC.ToF{..} ->
  61                 xmlCommonAttrs attrs $
  62                 XML.tof
  63                  !?? mayAttr XA.depth depth
  64
  65 xmlAbout :: DTC.About -> XML
  66 xmlAbout DTC.About{..} = do
  67         forM_ titles   $ xmlTitle
  68         forM_ authors  $ xmlAuthor
  69         forM_ editor   $ xmlEditor
  70         forM_ date     $ xmlDate
  71         whenMayText version xmlVersion
  72         forM_ keywords $ xmlKeyword
  73         forM_ links    $ xmlLink
  74         forM_ includes $ xmlInclude
  75
  76 xmlInclude :: DTC.Include -> XML
  77 xmlInclude DTC.Include{..} =
  78         XML.include True
  79          ! XA.href (attrValue href)
  80
  81 xmlKeyword :: Text -> XML
  82 xmlKeyword = XML.keyword . xmlText
  83
  84 xmlVersion :: MayText -> XML
  85 xmlVersion (MayText t) = XML.version $ xmlText t
  86
  87 xmlDate :: DTC.Date -> XML
  88 xmlDate DTC.Date{..} =
  89         XML.date
  90          !   XA.year (attrValue year)
  91          !?? mayAttr XA.month month
  92          !?? mayAttr XA.day day
  93
  94 xmlLink :: DTC.Link -> XML
  95 xmlLink DTC.Link{..} =
  96         XML.link
  97          !?? mayAttr XA.name name
  98          !?? mayAttr XA.rel  rel
  99          !?? mayAttr XA.href href
 100          $ xmlHorizontals body
 101
 102 xmlAddress :: DTC.Address -> XML
 103 xmlAddress DTC.Address{..} =
 104         XML.address
 105          !?? mayAttr XA.street street
 106          !?? mayAttr XA.zipcode zipcode
 107          !?? mayAttr XA.city    city
 108          !?? mayAttr XA.region  region
 109          !?? mayAttr XA.country country
 110          !?? mayAttr XA.email   email
 111          !?? mayAttr XA.tel     tel
 112          !?? mayAttr XA.fax     fax
 113
 114 xmlAuthor :: DTC.Entity -> XML
 115 xmlAuthor DTC.Entity{..} =
 116         XML.author
 117          !?? mayAttr XA.name name
 118          $ xmlAddress address
 119
 120 xmlEditor :: DTC.Entity -> XML
 121 xmlEditor DTC.Entity{..} =
 122         XML.editor
 123          !?? mayAttr XA.name name
 124          $ xmlAddress address
 125
 126 xmlTitle :: DTC.Title -> XML
 127 xmlTitle (DTC.Title t) = XML.title $ xmlHorizontals t
 128
 129 xmlAlias :: DTC.Alias -> XML
 130 xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
 131
 132 xmlId :: DTC.Ident -> B.Attribute
 133 xmlId (DTC.Ident i) = XA.id $ attrValue i
 134
 135 xmlVerticals :: DTC.Verticals -> XML
 136 xmlVerticals = (`forM_` xmlVertical)
 137
 138 xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
 139 xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
 140         (case ident of
 141          Nothing -> \m -> m
 142          Just (DTC.Ident i)  -> B.AddCustomAttribute "id" (B.Text i)) .
 143         case classes of
 144          [] -> \m -> m
 145          _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords classes)
 146
 147 xmlVertical :: DTC.Vertical -> XML
 148 xmlVertical = \case
 149          DTC.Para{..} ->
 150                 xmlCommonAttrs attrs $
 151                 XML.para $ xmlHorizontals horis
 152          DTC.OL{..} ->
 153                 xmlCommonAttrs attrs $
 154                 XML.ol $ forM_ items $ XML.li . xmlVerticals
 155          DTC.UL{..} ->
 156                 xmlCommonAttrs attrs $
 157                 XML.ul $ forM_ items $ XML.li . xmlVerticals
 158          DTC.RL{..} ->
 159                 xmlCommonAttrs attrs $
 160                 XML.rl $ forM_ refs $ xmlReference
 161          -- DTC.Index -> XML.index
 162          DTC.Figure{..} ->
 163                 xmlCommonAttrs attrs $
 164                 XML.figure
 165                  ! XA.type_ (attrValue type_) $ do
 166                         xmlTitle title
 167                         xmlVerticals verts
 168          DTC.Comment c ->
 169                 XML.comment c
 170          DTC.Artwork{..} ->
 171                 xmlCommonAttrs attrs $
 172                 XML.artwork mempty
 173
 174 xmlHorizontals :: DTC.Horizontals -> XML
 175 xmlHorizontals = (`forM_` xmlHorizontal)
 176
 177 xmlHorizontal :: DTC.Horizontal -> XML
 178 xmlHorizontal = \case
 179  DTC.Plain txt -> B.toMarkup txt
 180  DTC.BR -> XML.br
 181  DTC.B       hs -> XML.b    $ xmlHorizontals hs
 182  DTC.Code    hs -> XML.code $ xmlHorizontals hs
 183  DTC.Del     hs -> XML.del  $ xmlHorizontals hs
 184  DTC.I       hs -> XML.i    $ xmlHorizontals hs
 185  DTC.Note    hs -> XML.note $ xmlHorizontals hs
 186  DTC.Q       hs -> XML.q    $ xmlHorizontals hs
 187  DTC.SC      hs -> XML.sc   $ xmlHorizontals hs
 188  DTC.Sub     hs -> XML.sub  $ xmlHorizontals hs
 189  DTC.Sup     hs -> XML.sup  $ xmlHorizontals hs
 190  DTC.Eref to hs -> XML.eref ! XA.to (attrValue to) $ xmlHorizontals hs
 191  DTC.Iref to hs -> XML.iref ! XA.to (attrValue to) $ xmlHorizontals hs
 192  DTC.Ref  to hs -> XML.ref  ! XA.to (attrValue to) $ xmlHorizontals hs
 193  DTC.Rref to hs -> XML.rref ! XA.to (attrValue to) $ xmlHorizontals hs
 194
 195 xmlReference :: DTC.Reference -> XML
 196 xmlReference DTC.Reference{..} =
 197         XML.reference mempty