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                  PlainAt{..}   -> (if at_back then XML.at_back else XML.at)
 150                                    ! XA.to (attrify at_ident) $ xmlify ts
 151                  PlainTag{..}  -> (if tag_back then XML.tag_back else XML.at)
 152                                    ! XA.to (attrify tag_ident) $ xmlify ts
 153                  PlainRef{..}  -> XML.ref ! XA.to (attrify ref_ident) $ xmlify ts
 154
 155 instance Xmlify About where
 156         xmlify About{..} = do
 157                 XML.about
 158                  !?? mayAttr XA.url about_url
 159                  $ do
 160                         xmlify about_titles
 161                         xmlify about_authors
 162                         xmlify about_editor
 163                         xmlify about_date
 164                         forM_  about_tags $ XML.tag . xmlify
 165                         xmlify about_links
 166                         xmlify about_description
 167 instance Xmlify Include where
 168         xmlify Include{..} =
 169                 XML.include True
 170                  ! XA.href (attrify href)
 171 instance Xmlify Date where
 172         xmlify Date{..} =
 173                 XML.date
 174                  !   XA.year (attrify year)
 175                  !?? mayAttr XA.month month
 176                  !?? mayAttr XA.day day
 177 instance Xmlify Link where
 178         xmlify Link{..} =
 179                 XML.link
 180                  !?? mayAttr XA.name name
 181                  !?? mayAttr XA.rel  rel
 182                  !?? mayAttr XA.href href
 183                  $ xmlify plain
 184 instance Xmlify Entity where
 185         xmlify Entity{..} =
 186                 XML.entity
 187                  !?? mayAttr XA.name    entity_name
 188                  !?? mayAttr XA.street  entity_street
 189                  !?? mayAttr XA.zipcode entity_zipcode
 190                  !?? mayAttr XA.city    entity_city
 191                  !?? mayAttr XA.region  entity_region
 192                  !?? mayAttr XA.country entity_country
 193                  !?? mayAttr XA.email   entity_email
 194                  !?? mayAttr XA.tel     entity_tel
 195                  !?? mayAttr XA.fax     entity_fax
 196 instance Xmlify Title where
 197         xmlify (Title t) = XML.title $ xmlify t
 198 instance Xmlify Alias where
 199         xmlify Alias{..} =
 200                 xmlCommonAttrs alias_attrs $
 201                 XML.alias $
 202                         xmlify alias_title
 203 instance Xmlify Reference where
 204         xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
 205
 206 instance Xmlify a => Xmlify (Maybe a) where
 207         xmlify = foldMap xmlify
 208 instance Xmlify a => Xmlify [a] where
 209         xmlify = foldMap xmlify
 210 instance Xmlify a => Xmlify (Seq a) where
 211         xmlify = foldMap xmlify
 212
 213 xmlId :: Ident -> B.Attribute
 214 xmlId (Ident i) = XA.id $ attrify i
 215
 216 xmlCommonAttrs :: CommonAttrs -> XML -> XML
 217 xmlCommonAttrs CommonAttrs{..} =
 218         (case attrs_id of
 219          Nothing -> Fun.id
 220          Just (Ident i) ->
 221                 B.AddCustomAttribute "id" $
 222                 B.String $ TL.unpack i) .
 223         case attrs_classes of
 224          [] -> Fun.id
 225          _ ->
 226                 B.AddCustomAttribute "class" $
 227                 B.String $ TL.unpack $ TL.unwords attrs_classes