{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.DTC.Write.XML where import Control.Monad (forM_) import Data.Bool import Data.Foldable (Foldable(..)) import Data.Function (($), (.)) import Data.Functor ((<$>)) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq) import Data.TreeSeq.Strict (Tree(..)) import Text.Blaze ((!)) import Text.Blaze.Utils import Text.Blaze.XML (XML) import qualified Data.Char as Char import qualified Data.Function as Fun import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import qualified Text.Blaze as B import qualified Text.Blaze.DTC as XML import qualified Text.Blaze.DTC.Attributes as XA import qualified Text.Blaze.Internal as B import Data.Locale import Language.DTC.Anchor (plainifyWords) import Language.DTC.Document as DTC hiding (XML) document :: Locales ls => LocaleIn ls -> Document -> XML document loc Document{..} = do let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc XML.xmlModel "./schema/dtc.rnc" XML.xmlStylesheet $ "./xsl/document.html5."<>lang<>".xsl" XML.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl" XML.atomStylesheet $ "./xsl/document.atom."<>lang<>".xsl" XML.document $ do xmlify head xmlify body -- * Class 'Xmlify' class Xmlify a where xmlify :: a -> XML instance Xmlify TL.Text where xmlify = B.toMarkup instance Xmlify Head where xmlify Head{..} = xmlify about instance Xmlify (Tree BodyNode) where xmlify (Tree n ts) = case n of BodyBlock b -> xmlify b BodySection{..} -> xmlCommonAttrs attrs $ XML.section $ do xmlify title forM_ aliases xmlify xmlify ts instance Xmlify Block where xmlify = \case BlockPara para -> xmlify para BlockToC{..} -> xmlCommonAttrs attrs $ XML.toc !?? mayAttr XA.depth depth BlockToF{..} -> xmlCommonAttrs attrs $ XML.tof $ XML.ul $ forM_ types $ XML.li . xmlify BlockIndex{..} -> xmlCommonAttrs attrs $ XML.index $ do XML.ul $ forM_ terms $ \aliases -> XML.li $ xmlify $ TL.unlines $ plainifyWords <$> aliases BlockFigure{..} -> xmlCommonAttrs attrs $ XML.figure ! XA.type_ (attrify type_) $ do xmlify mayTitle xmlify paras BlockReferences{..} -> xmlCommonAttrs attrs $ XML.references $ xmlify refs instance Xmlify Para where xmlify = \case ParaItem{..} -> xmlify item ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items instance Xmlify ParaItem where xmlify = \case ParaPlain p -> XML.p $ xmlify p ParaComment c -> XML.comment $ TL.toStrict c ParaArtwork{..} -> XML.artwork ! XA.type_ (attrify type_) $ do xmlify text ParaQuote{..} -> XML.quote ! XA.type_ (attrify type_) $ do xmlify paras ParaOL items -> XML.ol $ forM_ items xmlify ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify instance Xmlify ListItem where xmlify ListItem{..} = XML.li ! XA.name (attrify name) $ xmlify paras instance Xmlify (Tree PlainNode) where xmlify (Tree n ts) = case n of PlainText t -> xmlify t PlainBR -> XML.br PlainGroup -> xmlify ts PlainB -> XML.b $ xmlify ts PlainCode -> XML.code $ xmlify ts PlainDel -> XML.del $ xmlify ts PlainI -> XML.i $ xmlify ts PlainNote{..} -> XML.note $ xmlify note PlainQ -> XML.q $ xmlify ts PlainSC -> XML.sc $ xmlify ts PlainSub -> XML.sub $ xmlify ts PlainSup -> XML.sup $ xmlify ts PlainU -> XML.u $ xmlify ts PlainEref to -> XML.eref ! XA.to (attrify to) $ xmlify ts PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts PlainRef to -> XML.ref ! XA.to (attrify to) $ xmlify ts PlainRref{..} -> XML.rref ! XA.to (attrify to) $ xmlify ts instance Xmlify About where xmlify About{..} = do XML.about !?? mayAttr XA.url url $ do xmlify titles xmlify authors xmlify editor xmlify date forM_ tags $ XML.tag . xmlify xmlify links xmlify includes instance Xmlify Include where xmlify Include{..} = XML.include True ! XA.href (attrify href) instance Xmlify Date where xmlify Date{..} = XML.date ! XA.year (attrify year) !?? mayAttr XA.month month !?? mayAttr XA.day day instance Xmlify Link where xmlify Link{..} = XML.link !?? mayAttr XA.name name !?? mayAttr XA.rel rel !?? mayAttr XA.href href $ xmlify plain instance Xmlify Entity where xmlify Entity{..} = XML.entity !?? mayAttr XA.name name !?? mayAttr XA.street street !?? mayAttr XA.zipcode zipcode !?? mayAttr XA.city city !?? mayAttr XA.region region !?? mayAttr XA.country country !?? mayAttr XA.email email !?? mayAttr XA.tel tel !?? mayAttr XA.fax fax instance Xmlify Title where xmlify (Title t) = XML.title $ xmlify t instance Xmlify Alias where xmlify Alias{..} = XML.alias !?? mayAttr XA.id id instance Xmlify Reference where xmlify Reference{..} = XML.reference mempty -- TODO: to be coded instance Xmlify a => Xmlify (Maybe a) where xmlify = foldMap xmlify instance Xmlify a => Xmlify [a] where xmlify = foldMap xmlify instance Xmlify a => Xmlify (Seq a) where xmlify = foldMap xmlify xmlId :: Ident -> B.Attribute xmlId (Ident i) = XA.id $ attrify i xmlCommonAttrs :: CommonAttrs -> XML -> XML xmlCommonAttrs CommonAttrs{id=ident, ..} = (case ident of Nothing -> Fun.id Just (Ident i) -> B.AddCustomAttribute "id" $ B.String $ TL.unpack i) . case classes of [] -> Fun.id _ -> B.AddCustomAttribute "class" $ B.String $ TL.unpack $ TL.unwords classes