1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Language.DTC.Write.XML where
6 import Control.Monad (forM_)
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
26 import Language.DTC.Anchor (plainifyWords)
27 import Language.DTC.Document as DTC hiding (XML)
29 document :: Locales ls => LocaleIn ls -> Document -> XML
30 document _loc Document{..} = do
31 XML.xmlModel "./schema/dtc.rnc"
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"
46 instance Xmlify TL.Text where
48 instance Xmlify Head where
51 instance Xmlify (Tree BodyNode) where
54 BodyBlock b -> xmlify b
56 xmlCommonAttrs attrs $
61 instance Xmlify Block where
63 BlockPara para -> xmlify para
65 xmlCommonAttrs attrs $
67 !?? mayAttr XA.depth depth
69 xmlCommonAttrs attrs $
75 xmlCommonAttrs attrs $
78 forM_ terms $ \aliases ->
82 plainifyWords <$> aliases
84 xmlCommonAttrs attrs $
86 ! XA.type_ (attrify type_) $ do
89 BlockReferences{..} ->
90 xmlCommonAttrs attrs $
91 XML.references $ xmlify refs
92 instance Xmlify Para where
94 ParaItem{..} -> xmlify item
95 ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items
96 instance Xmlify ParaItem where
98 ParaPlain p -> XML.p $ xmlify p
100 XML.comment $ TL.toStrict c
103 ! XA.type_ (attrify type_) $ do
107 ! XA.type_ (attrify type_) $ do
109 ParaOL items -> XML.ol $ forM_ items xmlify
110 ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify
111 instance Xmlify ListItem where
112 xmlify ListItem{..} =
113 XML.li ! XA.name (attrify name) $ xmlify paras
114 instance Xmlify (Tree PlainNode) where
117 PlainText t -> xmlify t
119 PlainGroup -> xmlify ts
120 PlainB -> XML.b $ xmlify ts
121 PlainCode -> XML.code $ xmlify ts
122 PlainDel -> XML.del $ xmlify ts
123 PlainI -> XML.i $ xmlify ts
124 PlainNote{..} -> XML.note $ xmlify note
125 PlainQ -> XML.q $ xmlify ts
126 PlainSC -> XML.sc $ xmlify ts
127 PlainSub -> XML.sub $ xmlify ts
128 PlainSup -> XML.sup $ xmlify ts
129 PlainU -> XML.u $ xmlify ts
130 PlainEref to -> XML.eref ! XA.to (attrify to) $ xmlify ts
131 PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts
132 PlainRef to -> XML.ref ! XA.to (attrify to) $ xmlify ts
133 PlainRref{..} -> XML.rref ! XA.to (attrify to) $ xmlify ts
135 instance Xmlify About where
136 xmlify About{..} = do
138 !?? mayAttr XA.url url
144 forM_ tags $ XML.tag . xmlify
147 instance Xmlify Include where
150 ! XA.href (attrify href)
151 instance Xmlify Date where
154 ! XA.year (attrify year)
155 !?? mayAttr XA.month month
156 !?? mayAttr XA.day day
157 instance Xmlify Link where
160 !?? mayAttr XA.name name
161 !?? mayAttr XA.rel rel
162 !?? mayAttr XA.href href
164 instance Xmlify Entity where
167 !?? mayAttr XA.name name
168 !?? mayAttr XA.street street
169 !?? mayAttr XA.zipcode zipcode
170 !?? mayAttr XA.city city
171 !?? mayAttr XA.region region
172 !?? mayAttr XA.country country
173 !?? mayAttr XA.email email
174 !?? mayAttr XA.tel tel
175 !?? mayAttr XA.fax fax
176 instance Xmlify Title where
177 xmlify (Title t) = XML.title $ xmlify t
178 instance Xmlify Alias where
179 xmlify Alias{..} = XML.alias !?? mayAttr XA.id id
180 instance Xmlify Reference where
181 xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
183 instance Xmlify a => Xmlify (Maybe a) where
184 xmlify = foldMap xmlify
185 instance Xmlify a => Xmlify [a] where
186 xmlify = foldMap xmlify
187 instance Xmlify a => Xmlify (Seq a) where
188 xmlify = foldMap xmlify
190 xmlId :: Ident -> B.Attribute
191 xmlId (Ident i) = XA.id $ attrify i
193 xmlCommonAttrs :: CommonAttrs -> XML -> XML
194 xmlCommonAttrs CommonAttrs{id=ident, ..} =
198 B.AddCustomAttribute "id" $
199 B.String $ TL.unpack i) .
203 B.AddCustomAttribute "class" $
204 B.String $ TL.unpack $ TL.unwords classes