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_)
   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                 xmlVerticals body
  60
  61 xmlHead :: DTC.Head -> XML
  62 xmlHead DTC.Head{..} =
  63         XML.about $ xmlAbout about
  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=DTC.Ident ident, ..} =
 140         (case ident of
 141          "" -> \m -> m
 142          i  -> B.AddCustomAttribute "id" (B.Text i)) .
 143         case class_ of
 144          [] -> \m -> m
 145          _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords class_)
 146
 147 xmlVertical :: DTC.Vertical -> XML
 148 xmlVertical = \case
 149          DTC.Section{..} ->
 150                 xmlCommonAttrs attrs $
 151                 XML.section $ do
 152                         xmlTitle title
 153                         forM_ aliases xmlAlias
 154                         xmlVerticals body
 155          DTC.Para as hs ->
 156                 xmlCommonAttrs as $
 157                 XML.para $ xmlHorizontals hs
 158          DTC.OL as vs ->
 159                 xmlCommonAttrs as $
 160                 XML.ol $ forM_ vs $ XML.li . xmlVerticals
 161          DTC.UL as vs ->
 162                 xmlCommonAttrs as $
 163                 XML.ul $ forM_ vs $ XML.li . xmlVerticals
 164          DTC.ToC as d ->
 165                 xmlCommonAttrs as $
 166                 XML.toc
 167                  !?? mayAttr XA.depth d
 168          DTC.ToF as d ->
 169                 xmlCommonAttrs as $
 170                 XML.tof
 171                  !?? mayAttr XA.depth d
 172          DTC.RL as rs ->
 173                 xmlCommonAttrs as $
 174                 XML.rl $ forM_ rs $ xmlReference
 175          -- DTC.Index -> XML.index
 176          DTC.Figure{..} ->
 177                 xmlCommonAttrs attrs $
 178                 XML.figure
 179                  ! XA.type_ (attrValue type_) $ do
 180                         xmlTitle title
 181                         xmlVerticals body
 182          DTC.Comment c ->
 183                 XML.comment c
 184          DTC.Artwork as _art ->
 185                 xmlCommonAttrs as $
 186                 XML.artwork mempty
 187
 188 xmlHorizontals :: DTC.Horizontals -> XML
 189 xmlHorizontals = (`forM_` xmlHorizontal)
 190
 191 xmlHorizontal :: DTC.Horizontal -> XML
 192 xmlHorizontal = \case
 193  DTC.Plain txt -> B.toMarkup txt
 194  DTC.BR -> XML.br
 195  DTC.B       hs -> XML.b    $ xmlHorizontals hs
 196  DTC.Code    hs -> XML.code $ xmlHorizontals hs
 197  DTC.Del     hs -> XML.del  $ xmlHorizontals hs
 198  DTC.I       hs -> XML.i    $ xmlHorizontals hs
 199  DTC.Note    hs -> XML.note $ xmlHorizontals hs
 200  DTC.Q       hs -> XML.q    $ xmlHorizontals hs
 201  DTC.SC      hs -> XML.sc   $ xmlHorizontals hs
 202  DTC.Sub     hs -> XML.sub  $ xmlHorizontals hs
 203  DTC.Sup     hs -> XML.sup  $ xmlHorizontals hs
 204  DTC.Eref to hs -> XML.eref ! XA.to (attrValue to) $ xmlHorizontals hs
 205  DTC.Iref to hs -> XML.iref ! XA.to (attrValue to) $ xmlHorizontals hs
 206  DTC.Ref  to hs -> XML.ref  ! XA.to (attrValue to) $ xmlHorizontals hs
 207  DTC.Rref to hs -> XML.rref ! XA.to (attrValue to) $ xmlHorizontals hs
 208
 209 xmlReference :: DTC.Reference -> XML
 210 xmlReference DTC.Reference{..} =
 211         XML.reference mempty