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