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                 forM_ document_head xmlify
  40                 xmlify document_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                 mempty
  51                 -- TODO: xmlify head_section
  52 instance Xmlify (Tree BodyNode) where
  53         xmlify (Tree n ts) =
  54                 case n of
  55                  BodyBlock b -> xmlify b
  56                  BodySection Section{..} ->
  57                         xmlCommonAttrs section_attrs $
  58                         XML.section $ do
  59                                 xmlify section_about
  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_ index $ \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 $ do
 158                         xmlify about_titles
 159                         xmlify about_aliases
 160                         forM_  about_authors xmlify
 161                         forM_  about_dates   xmlify
 162                         forM_  about_tags $ XML.tag . xmlify
 163                         forM_  about_links xmlify
 164                         xmlify about_description
 165                         xmlify about_judgments
 166 instance Xmlify Include where
 167         xmlify Include{..} =
 168                 XML.include True
 169                  ! XA.href (attrify include_href)
 170 instance Xmlify Date where
 171         xmlify Date{..} =
 172                 XML.date
 173                  !   XA.year (attrify date_year)
 174                  !?? mayAttr XA.rel   date_rel
 175                  !?? mayAttr XA.role  date_role
 176                  !?? mayAttr XA.month date_month
 177                  !?? mayAttr XA.day   date_day
 178 instance Xmlify Link where
 179         xmlify Link{..} =
 180                 XML.link
 181                  !?? mayAttr XA.rel   link_rel
 182                  !?? mayAttr XA.role  link_role
 183                  !?? mayAttr XA.href  link_url
 184                  -- !?? mayAttr XA.type_ link_type
 185                  $ xmlify link_plain
 186 instance Xmlify Entity where
 187         xmlify Entity{..} =
 188                 XML.entity
 189                  !?? mayAttr XA.rel     entity_rel
 190                  !?? mayAttr XA.role    entity_role
 191                  !?? mayAttr XA.name    entity_name
 192                  !?? mayAttr XA.street  entity_street
 193                  !?? mayAttr XA.zipcode entity_zipcode
 194                  !?? mayAttr XA.city    entity_city
 195                  !?? mayAttr XA.region  entity_region
 196                  !?? mayAttr XA.country entity_country
 197                  !?? mayAttr XA.email   entity_email
 198                  !?? mayAttr XA.tel     entity_tel
 199                  !?? mayAttr XA.fax     entity_fax
 200                  $ xmlify entity_org
 201 instance Xmlify Title where
 202         xmlify (Title t) = XML.title $ xmlify t
 203 instance Xmlify Alias where
 204         xmlify Alias{..} =
 205                 xmlCommonAttrs alias_attrs $
 206                 XML.alias $
 207                         xmlify alias_title
 208 instance Xmlify Reference where
 209         xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
 210
 211 instance Xmlify a => Xmlify (Maybe a) where
 212         xmlify = foldMap xmlify
 213 instance Xmlify a => Xmlify [a] where
 214         xmlify = foldMap xmlify
 215 instance Xmlify a => Xmlify (Seq a) where
 216         xmlify = foldMap xmlify
 217
 218 xmlId :: Ident -> B.Attribute
 219 xmlId (Ident i) = XA.id $ attrify i
 220
 221 xmlCommonAttrs :: CommonAttrs -> XML -> XML
 222 xmlCommonAttrs CommonAttrs{..} =
 223         (case attrs_id of
 224          Nothing -> Fun.id
 225          Just (Ident i) ->
 226                 B.AddCustomAttribute "id" $
 227                 B.String $ TL.unpack i) .
 228         case attrs_classes of
 229          [] -> Fun.id
 230          _ ->
 231                 B.AddCustomAttribute "class" $
 232                 B.String $ TL.unpack $ TL.unwords attrs_classes