]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/XML.hs
Fix href= in <toc>.
[doclang.git] / Language / DTC / Write / XML.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Language.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 Language.DTC.Anchor (plainifyWords)
27 import Language.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 PlainSC -> XML.sc $ xmlify ts
130 PlainSub -> XML.sub $ xmlify ts
131 PlainSup -> XML.sup $ xmlify ts
132 PlainU -> XML.u $ xmlify ts
133 PlainEref to -> XML.eref ! XA.to (attrify to) $ xmlify ts
134 PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts
135 PlainRef to -> XML.ref ! XA.to (attrify to) $ xmlify ts
136 PlainRref{..} -> XML.rref ! XA.to (attrify to) $ xmlify ts
137
138 instance Xmlify About where
139 xmlify About{..} = do
140 XML.about
141 !?? mayAttr XA.url url
142 $ do
143 xmlify titles
144 xmlify authors
145 xmlify editor
146 xmlify date
147 forM_ tags $ XML.tag . xmlify
148 xmlify links
149 xmlify includes
150 instance Xmlify Include where
151 xmlify Include{..} =
152 XML.include True
153 ! XA.href (attrify href)
154 instance Xmlify Date where
155 xmlify Date{..} =
156 XML.date
157 ! XA.year (attrify year)
158 !?? mayAttr XA.month month
159 !?? mayAttr XA.day day
160 instance Xmlify Link where
161 xmlify Link{..} =
162 XML.link
163 !?? mayAttr XA.name name
164 !?? mayAttr XA.rel rel
165 !?? mayAttr XA.href href
166 $ xmlify plain
167 instance Xmlify Entity where
168 xmlify Entity{..} =
169 XML.entity
170 !?? mayAttr XA.name name
171 !?? mayAttr XA.street street
172 !?? mayAttr XA.zipcode zipcode
173 !?? mayAttr XA.city city
174 !?? mayAttr XA.region region
175 !?? mayAttr XA.country country
176 !?? mayAttr XA.email email
177 !?? mayAttr XA.tel tel
178 !?? mayAttr XA.fax fax
179 instance Xmlify Title where
180 xmlify (Title t) = XML.title $ xmlify t
181 instance Xmlify Alias where
182 xmlify Alias{..} = XML.alias !?? mayAttr XA.id id
183 instance Xmlify Reference where
184 xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
185
186 instance Xmlify a => Xmlify (Maybe a) where
187 xmlify = foldMap xmlify
188 instance Xmlify a => Xmlify [a] where
189 xmlify = foldMap xmlify
190 instance Xmlify a => Xmlify (Seq a) where
191 xmlify = foldMap xmlify
192
193 xmlId :: Ident -> B.Attribute
194 xmlId (Ident i) = XA.id $ attrify i
195
196 xmlCommonAttrs :: CommonAttrs -> XML -> XML
197 xmlCommonAttrs CommonAttrs{id=ident, ..} =
198 (case ident of
199 Nothing -> Fun.id
200 Just (Ident i) ->
201 B.AddCustomAttribute "id" $
202 B.String $ TL.unpack i) .
203 case classes of
204 [] -> Fun.id
205 _ ->
206 B.AddCustomAttribute "class" $
207 B.String $ TL.unpack $ TL.unwords classes