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