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