]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Write/XML.hs
Rename Language -> Hdoc.
[doclang.git] / 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.Anchor (plainifyWords)
27 import Hdoc.DTC.Document as DTC hiding (XML)
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 xmlify head
40 xmlify 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 xmlify about
51 instance Xmlify (Tree BodyNode) where
52 xmlify (Tree n ts) =
53 case n of
54 BodyBlock b -> xmlify b
55 BodySection{..} ->
56 xmlCommonAttrs attrs $
57 XML.section $ do
58 xmlify title
59 forM_ aliases xmlify
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_ terms $ \aliases ->
82 XML.li $
83 xmlify $
84 TL.unlines $
85 plainifyWords <$> aliases
86 BlockFigure{..} ->
87 xmlCommonAttrs attrs $
88 XML.figure
89 ! XA.type_ (attrify type_) $ do
90 xmlify mayTitle
91 xmlify paras
92 BlockReferences{..} ->
93 xmlCommonAttrs attrs $
94 XML.references $ xmlify refs
95 instance Xmlify Para where
96 xmlify = \case
97 ParaItem{..} -> xmlify item
98 ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items
99 instance Xmlify ParaItem where
100 xmlify = \case
101 ParaPlain p -> XML.p $ xmlify p
102 ParaComment c ->
103 XML.comment $ TL.toStrict c
104 ParaArtwork{..} ->
105 XML.artwork
106 ! XA.type_ (attrify type_) $ do
107 xmlify text
108 ParaQuote{..} ->
109 XML.quote
110 ! XA.type_ (attrify type_) $ do
111 xmlify paras
112 ParaOL items -> XML.ol $ forM_ items xmlify
113 ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify
114 instance Xmlify ListItem where
115 xmlify ListItem{..} =
116 XML.li ! XA.name (attrify name) $ xmlify paras
117 instance Xmlify (Tree PlainNode) where
118 xmlify (Tree n ts) =
119 case n of
120 PlainText t -> xmlify t
121 PlainBreak -> XML.br
122 PlainGroup -> xmlify ts
123 PlainB -> XML.b $ xmlify ts
124 PlainCode -> XML.code $ xmlify ts
125 PlainDel -> XML.del $ xmlify ts
126 PlainI -> XML.i $ xmlify ts
127 PlainNote{..} -> XML.note $ xmlify note
128 PlainQ -> XML.q $ xmlify ts
129 PlainSpan{..} -> xmlCommonAttrs attrs $ XML.span $ xmlify ts
130 PlainSC -> XML.sc $ xmlify ts
131 PlainSub -> XML.sub $ xmlify ts
132 PlainSup -> XML.sup $ xmlify ts
133 PlainU -> XML.u $ xmlify ts
134 PlainEref to -> XML.eref ! XA.to (attrify to) $ xmlify ts
135 PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts
136 PlainRef to -> XML.ref ! XA.to (attrify $ unIdent to) $ xmlify ts
137 PlainRref{..} -> XML.rref ! XA.to (attrify $ unIdent to) $ xmlify ts
138
139 instance Xmlify About where
140 xmlify About{..} = do
141 XML.about
142 !?? mayAttr XA.url url
143 $ do
144 xmlify titles
145 xmlify authors
146 xmlify editor
147 xmlify date
148 forM_ tags $ XML.tag . xmlify
149 xmlify links
150 xmlify includes
151 instance Xmlify Include where
152 xmlify Include{..} =
153 XML.include True
154 ! XA.href (attrify href)
155 instance Xmlify Date where
156 xmlify Date{..} =
157 XML.date
158 ! XA.year (attrify year)
159 !?? mayAttr XA.month month
160 !?? mayAttr XA.day day
161 instance Xmlify Link where
162 xmlify Link{..} =
163 XML.link
164 !?? mayAttr XA.name name
165 !?? mayAttr XA.rel rel
166 !?? mayAttr XA.href href
167 $ xmlify plain
168 instance Xmlify Entity where
169 xmlify Entity{..} =
170 XML.entity
171 !?? mayAttr XA.name name
172 !?? mayAttr XA.street street
173 !?? mayAttr XA.zipcode zipcode
174 !?? mayAttr XA.city city
175 !?? mayAttr XA.region region
176 !?? mayAttr XA.country country
177 !?? mayAttr XA.email email
178 !?? mayAttr XA.tel tel
179 !?? mayAttr XA.fax fax
180 instance Xmlify Title where
181 xmlify (Title t) = XML.title $ xmlify t
182 instance Xmlify Alias where
183 xmlify Alias{..} = XML.alias !?? mayAttr XA.id id
184 instance Xmlify Reference where
185 xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
186
187 instance Xmlify a => Xmlify (Maybe a) where
188 xmlify = foldMap xmlify
189 instance Xmlify a => Xmlify [a] where
190 xmlify = foldMap xmlify
191 instance Xmlify a => Xmlify (Seq a) where
192 xmlify = foldMap xmlify
193
194 xmlId :: Ident -> B.Attribute
195 xmlId (Ident i) = XA.id $ attrify i
196
197 xmlCommonAttrs :: CommonAttrs -> XML -> XML
198 xmlCommonAttrs CommonAttrs{id=ident, ..} =
199 (case ident of
200 Nothing -> Fun.id
201 Just (Ident i) ->
202 B.AddCustomAttribute "id" $
203 B.String $ TL.unpack i) .
204 case classes of
205 [] -> Fun.id
206 _ ->
207 B.AddCustomAttribute "class" $
208 B.String $ TL.unpack $ TL.unwords classes