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