Hdoc/DTC/Write/XML.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Hdoc.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.Functor ((<$>))
  11 import Data.Maybe (Maybe(..))
  12 import Data.Monoid (Monoid(..))
  13 import Data.Sequence (Seq)
  14 import Data.TreeSeq.Strict (Tree(..))
  15 import Text.Blaze ((!))
  16 import Text.Blaze.Utils
  17 import Text.Blaze.XML (XML)
  18 import qualified Data.Function as Fun
  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 Hdoc.DTC.Analyze.Index (plainifyWords)
  27 import Hdoc.DTC.Document as DTC
  28
  29 writeXML :: Locales ls => LocaleIn ls -> Document -> XML
  30 writeXML _loc Document{..} = do
  31         XML.xmlModel "./schema/dtc.rnc"
  32         {-
  33         let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
  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         -}
  38         XML.document $ do
  39                 xmlify head
  40                 xmlify body
  41
  42 -- * Class 'Xmlify'
  43 class Xmlify a where
  44         xmlify :: a -> XML
  45
  46 instance Xmlify TL.Text where
  47         xmlify = B.toMarkup
  48 instance Xmlify Head where
  49         xmlify Head{..} =
  50                 xmlify head_about
  51 instance Xmlify (Tree BodyNode) where
  52         xmlify (Tree n ts) =
  53                 case n of
  54                  BodyBlock b -> xmlify b
  55                  BodySection Section{..} ->
  56                         xmlCommonAttrs section_attrs $
  57                         XML.section $ do
  58                                 xmlify section_title
  59                                 forM_ section_aliases xmlify
  60                                 xmlify ts
  61 instance Xmlify Block where
  62         xmlify = \case
  63          BlockPara para -> xmlify para
  64          BlockBreak{..} ->
  65                 xmlCommonAttrs attrs $
  66                 XML.break
  67          BlockToC{..} ->
  68                 xmlCommonAttrs attrs $
  69                 XML.toc
  70                  !?? mayAttr XA.depth depth
  71          BlockToF{..} ->
  72                 xmlCommonAttrs attrs $
  73                 XML.tof $
  74                         XML.ul $
  75                                 forM_ types $
  76                                         XML.li . xmlify
  77          BlockIndex{..} ->
  78                 xmlCommonAttrs attrs $
  79                 XML.index $ do
  80                         XML.ul $
  81                                 forM_ terms $ \aliases ->
  82                                         XML.li $
  83                                                 xmlify $
  84                                                 TL.unlines $
  85                                                 plainifyWords <$> aliases
  86          BlockAside{..} ->
  87                 xmlCommonAttrs attrs $
  88                 XML.aside $ do
  89                         xmlify blocks
  90          BlockFigure{..} ->
  91                 xmlCommonAttrs attrs $
  92                 XML.figure
  93                  ! XA.type_ (attrify type_) $ do
  94                         xmlify mayTitle
  95                         xmlify paras
  96          BlockReferences{..} ->
  97                 xmlCommonAttrs attrs $
  98                 XML.references $ xmlify refs
  99 instance Xmlify Para where
 100         xmlify = \case
 101          ParaItem{..}  -> xmlify item
 102          ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items
 103 instance Xmlify ParaItem where
 104         xmlify = \case
 105          ParaPlain p -> XML.p $ xmlify p
 106          ParaComment c ->
 107                 XML.comment $ TL.toStrict c
 108          ParaArtwork{..} ->
 109                 XML.artwork
 110                  ! XA.type_ (attrify type_) $ do
 111                         xmlify text
 112          ParaQuote{..} ->
 113                 XML.quote
 114                  ! XA.type_ (attrify type_) $ do
 115                         xmlify paras
 116          ParaOL items -> XML.ol $ forM_ items xmlify
 117          ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify
 118          ParaJudgment j -> xmlify j
 119 instance Xmlify Judgment where
 120         xmlify = \case
 121          Judgment{..} ->
 122                 XML.judgment
 123                  ! XA.judges (attrify judgment_judgesId)
 124                  ! XA.grades (attrify judgment_gradesId) $
 125                         xmlify judgment_question
 126                         -- TODO: xmlify judgment_choices
 127 instance Xmlify ListItem where
 128         xmlify ListItem{..} =
 129                 XML.li ! XA.name (attrify name) $ xmlify paras
 130 instance Xmlify (Tree PlainNode) where
 131         xmlify (Tree n ts) =
 132                 case n of
 133                  PlainText t   -> xmlify t
 134                  PlainBreak    -> XML.br
 135                  PlainGroup    -> xmlify ts
 136                  PlainB        -> XML.b    $ xmlify ts
 137                  PlainCode     -> XML.code $ xmlify ts
 138                  PlainDel      -> XML.del  $ xmlify ts
 139                  PlainI        -> XML.i    $ xmlify ts
 140                  PlainNote{..} -> XML.note $ xmlify note_paras
 141                  PlainQ        -> XML.q    $ xmlify ts
 142                  PlainSpan{..} -> xmlCommonAttrs attrs $ XML.span $ xmlify ts
 143                  PlainSC       -> XML.sc   $ xmlify ts
 144                  PlainSub      -> XML.sub  $ xmlify ts
 145                  PlainSup      -> XML.sup  $ xmlify ts
 146                  PlainU        -> XML.u    $ xmlify ts
 147                  PlainEref to  -> XML.eref ! XA.to (attrify to) $ xmlify ts
 148                  PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords iref_term) $ xmlify ts
 149                  PlainTag{..}  -> XML.tag  $ xmlify ts
 150                  PlainRref{..} -> XML.rref ! XA.to (attrify rref_to) $ xmlify ts
 151
 152 instance Xmlify About where
 153         xmlify About{..} = do
 154                 XML.about
 155                  !?? mayAttr XA.url about_url
 156                  $ do
 157                         xmlify about_titles
 158                         xmlify about_authors
 159                         xmlify about_editor
 160                         xmlify about_date
 161                         forM_  about_tags $ XML.tag . xmlify
 162                         xmlify about_links
 163                         xmlify about_description
 164 instance Xmlify Include where
 165         xmlify Include{..} =
 166                 XML.include True
 167                  ! XA.href (attrify href)
 168 instance Xmlify Date where
 169         xmlify Date{..} =
 170                 XML.date
 171                  !   XA.year (attrify year)
 172                  !?? mayAttr XA.month month
 173                  !?? mayAttr XA.day day
 174 instance Xmlify Link where
 175         xmlify Link{..} =
 176                 XML.link
 177                  !?? mayAttr XA.name name
 178                  !?? mayAttr XA.rel  rel
 179                  !?? mayAttr XA.href href
 180                  $ xmlify plain
 181 instance Xmlify Entity where
 182         xmlify Entity{..} =
 183                 XML.entity
 184                  !?? mayAttr XA.name    entity_name
 185                  !?? mayAttr XA.street  entity_street
 186                  !?? mayAttr XA.zipcode entity_zipcode
 187                  !?? mayAttr XA.city    entity_city
 188                  !?? mayAttr XA.region  entity_region
 189                  !?? mayAttr XA.country entity_country
 190                  !?? mayAttr XA.email   entity_email
 191                  !?? mayAttr XA.tel     entity_tel
 192                  !?? mayAttr XA.fax     entity_fax
 193 instance Xmlify Title where
 194         xmlify (Title t) = XML.title $ xmlify t
 195 instance Xmlify Alias where
 196         xmlify Alias{..} = XML.alias $ xmlify title
 197 instance Xmlify Reference where
 198         xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
 199
 200 instance Xmlify a => Xmlify (Maybe a) where
 201         xmlify = foldMap xmlify
 202 instance Xmlify a => Xmlify [a] where
 203         xmlify = foldMap xmlify
 204 instance Xmlify a => Xmlify (Seq a) where
 205         xmlify = foldMap xmlify
 206
 207 xmlId :: Ident -> B.Attribute
 208 xmlId (Ident i) = XA.id $ attrify i
 209
 210 xmlCommonAttrs :: CommonAttrs -> XML -> XML
 211 xmlCommonAttrs CommonAttrs{id=ident, ..} =
 212         (case ident of
 213          Nothing -> Fun.id
 214          Just (Ident i) ->
 215                 B.AddCustomAttribute "id" $
 216                 B.String $ TL.unpack i) .
 217         case classes of
 218          [] -> Fun.id
 219          _ ->
 220                 B.AddCustomAttribute "class" $
 221                 B.String $ TL.unpack $ TL.unwords classes