-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.DTC.Write.XML where
--- import Data.Foldable (Foldable(..))
-import Control.Monad (forM_, mapM_)
+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.Text (Text)
+import Data.Sequence (Seq)
+import Data.TreeSeq.Strict (Tree(..))
import Text.Blaze ((!))
import Text.Blaze.Utils
import Text.Blaze.XML (XML)
-import Data.TreeSeq.Strict (Tree(..))
-import qualified Data.Char as Char
-import qualified Data.Map.Strict as Map
-import qualified Data.Text as Text
+import qualified Data.Function as Fun
+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.Document (MayText(..), whenMayText)
-import qualified Language.DTC.Document as DTC
-
-xmlText :: Text -> XML
-xmlText = B.toMarkup
+import Language.DTC.Anchor (plainifyWords)
+import Language.DTC.Document as DTC hiding (XML)
-xmlDocument :: Locales ls => LocaleIn ls -> DTC.Document -> XML
-xmlDocument loc DTC.Document{..} = do
- let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
+writeXML :: Locales ls => LocaleIn ls -> Document -> XML
+writeXML _loc Document{..} = do
XML.xmlModel "./schema/dtc.rnc"
+ {-
+ let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
XML.xmlStylesheet $ "./xsl/document.html5."<>lang<>".xsl"
XML.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
XML.atomStylesheet $ "./xsl/document.atom."<>lang<>".xsl"
+ -}
XML.document $ do
- xmlHead head
- xmlBody body
-
-xmlHead :: DTC.Head -> XML
-xmlHead DTC.Head{..} =
- XML.about $ xmlAbout about
-
-xmlBody :: DTC.Body -> XML
-xmlBody = mapM_ $ \case
- TreeN k ts -> xmlBodyKey k $ xmlBody ts
- Tree0 vs -> xmlBodyValue `mapM_` vs
-
-xmlBodyKey :: DTC.BodyKey -> XML -> XML
-xmlBodyKey k body = case k of
- DTC.Section{..} ->
+ 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
+ BlockBreak{..} ->
xmlCommonAttrs attrs $
- XML.section $ do
- xmlTitle title
- forM_ aliases xmlAlias
- body
-
-xmlBodyValue :: DTC.BodyValue -> XML
-xmlBodyValue = \case
- DTC.ToC{..} ->
+ XML.break
+ BlockToC{..} ->
xmlCommonAttrs attrs $
XML.toc
!?? mayAttr XA.depth depth
- DTC.ToF{..} ->
+ BlockToF{..} ->
xmlCommonAttrs attrs $
- XML.tof
- !?? mayAttr XA.depth depth
- DTC.Figure{..} ->
+ 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_ (attrValue type_) $ do
- xmlTitle title
- xmlVerticals verts
- DTC.Vertical v -> xmlVertical v
-
-xmlAbout :: DTC.About -> XML
-xmlAbout DTC.About{..} = do
- forM_ titles $ xmlTitle
- forM_ authors $ xmlAuthor
- forM_ editor $ xmlEditor
- forM_ date $ xmlDate
- whenMayText version xmlVersion
- forM_ keywords $ xmlKeyword
- forM_ links $ xmlLink
- forM_ includes $ xmlInclude
-
-xmlInclude :: DTC.Include -> XML
-xmlInclude DTC.Include{..} =
- XML.include True
- ! XA.href (attrValue href)
-
-xmlKeyword :: Text -> XML
-xmlKeyword = XML.keyword . xmlText
-
-xmlVersion :: MayText -> XML
-xmlVersion (MayText t) = XML.version $ xmlText t
-
-xmlDate :: DTC.Date -> XML
-xmlDate DTC.Date{..} =
- XML.date
- ! XA.year (attrValue year)
- !?? mayAttr XA.month month
- !?? mayAttr XA.day day
-
-xmlLink :: DTC.Link -> XML
-xmlLink DTC.Link{..} =
- XML.link
- !?? mayAttr XA.name name
- !?? mayAttr XA.rel rel
- !?? mayAttr XA.href href
- $ xmlHorizontals body
-
-xmlAddress :: DTC.Address -> XML
-xmlAddress DTC.Address{..} =
- XML.address
- !?? 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
-
-xmlAuthor :: DTC.Entity -> XML
-xmlAuthor DTC.Entity{..} =
- XML.author
- !?? mayAttr XA.name name
- $ xmlAddress address
-
-xmlEditor :: DTC.Entity -> XML
-xmlEditor DTC.Entity{..} =
- XML.editor
- !?? mayAttr XA.name name
- $ xmlAddress address
-
-xmlTitle :: DTC.Title -> XML
-xmlTitle (DTC.Title t) = XML.title $ xmlHorizontals t
-
-xmlAlias :: DTC.Alias -> XML
-xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
-
-xmlId :: DTC.Ident -> B.Attribute
-xmlId (DTC.Ident i) = XA.id $ attrValue i
-
-xmlVerticals :: DTC.Verticals -> XML
-xmlVerticals = (`forM_` xmlVertical)
-
-xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
-xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
+ ! 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
+ PlainBreak -> 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 -> \m -> m
- Just (DTC.Ident i) -> B.AddCustomAttribute "id" (B.Text i)) .
+ Nothing -> Fun.id
+ Just (Ident i) ->
+ B.AddCustomAttribute "id" $
+ B.String $ TL.unpack i) .
case classes of
- [] -> \m -> m
- _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords classes)
-
-xmlVertical :: DTC.Vertical -> XML
-xmlVertical = \case
- DTC.Para{..} ->
- xmlCommonAttrs attrs $
- XML.para $ xmlHorizontals horis
- DTC.OL{..} ->
- xmlCommonAttrs attrs $
- XML.ol $ forM_ items $ XML.li . xmlVerticals
- DTC.UL{..} ->
- xmlCommonAttrs attrs $
- XML.ul $ forM_ items $ XML.li . xmlVerticals
- DTC.RL{..} ->
- xmlCommonAttrs attrs $
- XML.rl $ forM_ refs $ xmlReference
- -- DTC.Index -> XML.index
- DTC.Comment c ->
- XML.comment c
- DTC.Artwork{..} ->
- xmlCommonAttrs attrs $
- XML.artwork mempty
-
-xmlHorizontals :: DTC.Horizontals -> XML
-xmlHorizontals = (`forM_` xmlHorizontal)
-
-xmlHorizontal :: DTC.Horizontal -> XML
-xmlHorizontal = \case
- DTC.Plain txt -> B.toMarkup txt
- DTC.BR -> XML.br
- DTC.B hs -> XML.b $ xmlHorizontals hs
- DTC.Code hs -> XML.code $ xmlHorizontals hs
- DTC.Del hs -> XML.del $ xmlHorizontals hs
- DTC.I hs -> XML.i $ xmlHorizontals hs
- DTC.Note hs -> XML.note $ xmlHorizontals hs
- DTC.Q hs -> XML.q $ xmlHorizontals hs
- DTC.SC hs -> XML.sc $ xmlHorizontals hs
- DTC.Sub hs -> XML.sub $ xmlHorizontals hs
- DTC.Sup hs -> XML.sup $ xmlHorizontals hs
- DTC.Eref to hs -> XML.eref ! XA.to (attrValue to) $ xmlHorizontals hs
- DTC.Iref to hs -> XML.iref ! XA.to (attrValue to) $ xmlHorizontals hs
- DTC.Ref to hs -> XML.ref ! XA.to (attrValue to) $ xmlHorizontals hs
- DTC.Rref to hs -> XML.rref ! XA.to (attrValue to) $ xmlHorizontals hs
-
-xmlReference :: DTC.Reference -> XML
-xmlReference DTC.Reference{..} =
- XML.reference mempty
+ [] -> Fun.id
+ _ ->
+ B.AddCustomAttribute "class" $
+ B.String $ TL.unpack $ TL.unwords classes