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