]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/XML.hs
Use Loqualization.
[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 document :: Locales ls => LocaleIn ls -> Document -> XML
30 document _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 BlockToC{..} ->
65 xmlCommonAttrs attrs $
66 XML.toc
67 !?? mayAttr XA.depth depth
68 BlockToF{..} ->
69 xmlCommonAttrs attrs $
70 XML.tof $
71 XML.ul $
72 forM_ types $
73 XML.li . xmlify
74 BlockIndex{..} ->
75 xmlCommonAttrs attrs $
76 XML.index $ do
77 XML.ul $
78 forM_ terms $ \aliases ->
79 XML.li $
80 xmlify $
81 TL.unlines $
82 plainifyWords <$> aliases
83 BlockFigure{..} ->
84 xmlCommonAttrs attrs $
85 XML.figure
86 ! XA.type_ (attrify type_) $ do
87 xmlify mayTitle
88 xmlify paras
89 BlockReferences{..} ->
90 xmlCommonAttrs attrs $
91 XML.references $ xmlify refs
92 instance Xmlify Para where
93 xmlify = \case
94 ParaItem{..} -> xmlify item
95 ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items
96 instance Xmlify ParaItem where
97 xmlify = \case
98 ParaPlain p -> XML.p $ xmlify p
99 ParaComment c ->
100 XML.comment $ TL.toStrict c
101 ParaArtwork{..} ->
102 XML.artwork
103 ! XA.type_ (attrify type_) $ do
104 xmlify text
105 ParaQuote{..} ->
106 XML.quote
107 ! XA.type_ (attrify type_) $ do
108 xmlify paras
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
115 xmlify (Tree n ts) =
116 case n of
117 PlainText t -> xmlify t
118 PlainBR -> XML.br
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
134
135 instance Xmlify About where
136 xmlify About{..} = do
137 XML.about
138 !?? mayAttr XA.url url
139 $ do
140 xmlify titles
141 xmlify authors
142 xmlify editor
143 xmlify date
144 forM_ tags $ XML.tag . xmlify
145 xmlify links
146 xmlify includes
147 instance Xmlify Include where
148 xmlify Include{..} =
149 XML.include True
150 ! XA.href (attrify href)
151 instance Xmlify Date where
152 xmlify Date{..} =
153 XML.date
154 ! XA.year (attrify year)
155 !?? mayAttr XA.month month
156 !?? mayAttr XA.day day
157 instance Xmlify Link where
158 xmlify Link{..} =
159 XML.link
160 !?? mayAttr XA.name name
161 !?? mayAttr XA.rel rel
162 !?? mayAttr XA.href href
163 $ xmlify plain
164 instance Xmlify Entity where
165 xmlify Entity{..} =
166 XML.entity
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
182
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
189
190 xmlId :: Ident -> B.Attribute
191 xmlId (Ident i) = XA.id $ attrify i
192
193 xmlCommonAttrs :: CommonAttrs -> XML -> XML
194 xmlCommonAttrs CommonAttrs{id=ident, ..} =
195 (case ident of
196 Nothing -> Fun.id
197 Just (Ident i) ->
198 B.AddCustomAttribute "id" $
199 B.String $ TL.unpack i) .
200 case classes of
201 [] -> Fun.id
202 _ ->
203 B.AddCustomAttribute "class" $
204 B.String $ TL.unpack $ TL.unwords classes