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