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 Text.Blaze ((!))
  13 import Text.Blaze.Utils
  14 import Text.Blaze.XML (XML)
  15 import Data.TreeSeq.Strict (Tree(..))
  16 import qualified Data.Char as Char
  17 import qualified Data.Map.Strict as Map
  18 import qualified Data.Text as Text
  19 import qualified Data.Text.Lazy as TL
  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 document :: Locales ls => LocaleIn ls -> DTC.Document -> XML
  31 document loc DTC.Document{..} = do
  32         let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
  33         XML.xmlModel "./schema/dtc.rnc"
  34         XML.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
  35         XML.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
  36         XML.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
  37         XML.document $ do
  38                 xmlHead head
  39                 xmlBody body
  40
  41 xmlText :: TL.Text -> XML
  42 xmlText = B.toMarkup
  43
  44 xmlHead :: DTC.Head -> XML
  45 xmlHead DTC.Head{..} =
  46         XML.about $ xmlAbout about
  47
  48 xmlBody :: DTC.Body -> XML
  49 xmlBody = mapM_ $ \(Tree n ts) ->
  50         case n of
  51          DTC.Section{..} ->
  52                 xmlCommonAttrs attrs $
  53                 XML.section $ do
  54                         xmlTitle title
  55                         forM_ aliases xmlAlias
  56                         xmlBody ts
  57          DTC.ToC{..} ->
  58                 xmlCommonAttrs attrs $
  59                 XML.toc
  60                  !?? mayAttr XA.depth depth
  61          DTC.ToF{..} ->
  62                 xmlCommonAttrs attrs $
  63                 XML.tof $
  64                         XML.ul $
  65                                 forM_ types $
  66                                         XML.li . xmlText
  67          DTC.Index{..} ->
  68                 xmlCommonAttrs attrs $
  69                 XML.index $ do
  70                         XML.ul $
  71                                 forM_ terms $ \aliases ->
  72                                         XML.li $
  73                                                 xmlText $
  74                                                 TL.unlines $
  75                                                 plainifyWords <$> aliases
  76          DTC.Figure{..} ->
  77                 xmlCommonAttrs attrs $
  78                 XML.figure
  79                  ! XA.type_ (attrify type_) $ do
  80                         forM_ mayTitle xmlTitle
  81                         xmlBlocks blocks
  82          DTC.References{..} ->
  83                 xmlCommonAttrs attrs $
  84                 XML.references $ forM_ refs $ xmlReference
  85          DTC.Block v -> xmlBlock v
  86
  87 xmlAbout :: DTC.About -> XML
  88 xmlAbout DTC.About{..} = do
  89         forM_ titles   $ xmlTitle
  90         forM_ authors  $ xmlEntity
  91         forM_ editor   $ xmlEntity
  92         forM_ date     $ xmlDate
  93         whenMayText version xmlVersion
  94         forM_ keywords $ xmlKeyword
  95         forM_ links    $ xmlLink
  96         forM_ includes $ xmlInclude
  97
  98 xmlInclude :: DTC.Include -> XML
  99 xmlInclude DTC.Include{..} =
 100         XML.include True
 101          ! XA.href (attrify href)
 102
 103 xmlKeyword :: TL.Text -> XML
 104 xmlKeyword = XML.keyword . xmlText
 105
 106 xmlVersion :: MayText -> XML
 107 xmlVersion (MayText t) = XML.version $ xmlText t
 108
 109 xmlDate :: DTC.Date -> XML
 110 xmlDate DTC.Date{..} =
 111         XML.date
 112          !   XA.year (attrify year)
 113          !?? mayAttr XA.month month
 114          !?? mayAttr XA.day day
 115
 116 xmlLink :: DTC.Link -> XML
 117 xmlLink DTC.Link{..} =
 118         XML.link
 119          !?? mayAttr XA.name name
 120          !?? mayAttr XA.rel  rel
 121          !?? mayAttr XA.href href
 122          $ xmlPara para
 123
 124 xmlEntity :: DTC.Entity -> XML
 125 xmlEntity DTC.Entity{..} =
 126         XML.entity
 127          !?? mayAttr XA.name    name
 128          !?? mayAttr XA.street  street
 129          !?? mayAttr XA.zipcode zipcode
 130          !?? mayAttr XA.city    city
 131          !?? mayAttr XA.region  region
 132          !?? mayAttr XA.country country
 133          !?? mayAttr XA.email   email
 134          !?? mayAttr XA.tel     tel
 135          !?? mayAttr XA.fax     fax
 136
 137 xmlTitle :: DTC.Title -> XML
 138 xmlTitle (DTC.Title t) = XML.title $ xmlPara t
 139
 140 xmlAlias :: DTC.Alias -> XML
 141 xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
 142
 143 xmlId :: DTC.Ident -> B.Attribute
 144 xmlId (DTC.Ident i) = XA.id $ attrify i
 145
 146 xmlBlocks :: DTC.Blocks -> XML
 147 xmlBlocks = (`forM_` xmlBlock)
 148
 149 xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
 150 xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
 151         (case ident of
 152          Nothing -> \m -> m
 153          Just (DTC.Ident i) ->
 154                 B.AddCustomAttribute "id" $
 155                 B.String $ TL.unpack i) .
 156         case classes of
 157          [] -> \m -> m
 158          _ ->
 159                 B.AddCustomAttribute "class" $
 160                 B.String $ TL.unpack $ TL.unwords classes
 161
 162 xmlBlock :: DTC.Block -> XML
 163 xmlBlock = \case
 164          DTC.Para{..} ->
 165                 xmlCommonAttrs attrs $
 166                 XML.para $ xmlPara para
 167          DTC.OL{..} ->
 168                 xmlCommonAttrs attrs $
 169                 XML.ol $ forM_ items $ XML.li . xmlBlocks
 170          DTC.UL{..} ->
 171                 xmlCommonAttrs attrs $
 172                 XML.ul $ forM_ items $ XML.li . xmlBlocks
 173          DTC.Comment c ->
 174                 XML.comment $ TL.toStrict c
 175          DTC.Artwork{..} ->
 176                 xmlCommonAttrs attrs $
 177                 XML.artwork
 178                  ! XA.type_ (attrify type_) $ do
 179                         xmlText text
 180          DTC.Quote{..} ->
 181                 xmlCommonAttrs attrs $
 182                 XML.quote
 183                  ! XA.type_ (attrify type_) $ do
 184                         xmlBlocks blocks
 185
 186 xmlPara :: DTC.Para -> XML
 187 xmlPara = (`forM_` xmlLine)
 188
 189 xmlLine :: DTC.Lines -> XML
 190 xmlLine (Tree n ls) =
 191         case n of
 192          DTC.Plain p -> B.toMarkup p
 193          DTC.BR      -> XML.br
 194          DTC.B        -> XML.b    $ xmlPara ls
 195          DTC.Code     -> XML.code $ xmlPara ls
 196          DTC.Del      -> XML.del  $ xmlPara ls
 197          DTC.I        -> XML.i    $ xmlPara ls
 198          DTC.Note{..} -> XML.note $ xmlPara ls
 199          DTC.Q        -> XML.q    $ xmlPara ls
 200          DTC.SC       -> XML.sc   $ xmlPara ls
 201          DTC.Sub      -> XML.sub  $ xmlPara ls
 202          DTC.Sup      -> XML.sup  $ xmlPara ls
 203          DTC.U        -> XML.u    $ xmlPara ls
 204          DTC.Eref to  -> XML.eref ! XA.to (attrify to) $ xmlPara ls
 205          DTC.Iref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlPara ls
 206          DTC.Ref  to  -> XML.ref  ! XA.to (attrify to) $ xmlPara ls
 207          DTC.Rref{..} -> XML.rref ! XA.to (attrify to) $ xmlPara ls
 208
 209 xmlReference :: DTC.Reference -> XML
 210 xmlReference DTC.Reference{..} =
 211         XML.reference mempty