]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/XML.hs
Fix HTML5 rendering of NodePara.
[doclang.git] / Language / DTC / Write / XML.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 module Language.DTC.Write.XML where
4
5 import Control.Monad (forM_, mapM_)
6 import Data.Bool
7 import Data.Function (($), (.))
8 import Data.Functor ((<$>))
9 import Data.Maybe (Maybe(..))
10 import Data.Monoid (Monoid(..))
11 import Data.Semigroup (Semigroup(..))
12 import Text.Blaze ((!))
13 import Text.Blaze.Utils
14 import Text.Blaze.XML (XML)
15 import Data.TreeSeq.Strict (Tree(..))
16 import qualified Data.Char as Char
17 import qualified Data.Map.Strict as Map
18 import qualified Data.Text as Text
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.Document (MayText(..), whenMayText)
27 import Language.DTC.Anchor (plainifyWords)
28 import qualified Language.DTC.Document as DTC
29
30 document :: Locales ls => LocaleIn ls -> DTC.Document -> XML
31 document loc DTC.Document{..} = do
32 let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
33 XML.xmlModel "./schema/dtc.rnc"
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 XML.document $ do
38 xmlHead head
39 xmlBody body
40
41 xmlText :: TL.Text -> XML
42 xmlText = B.toMarkup
43
44 xmlHead :: DTC.Head -> XML
45 xmlHead DTC.Head{..} =
46 XML.about $ xmlAbout about
47
48 xmlBody :: DTC.Body -> XML
49 xmlBody = mapM_ $ \(Tree n ts) ->
50 case n of
51 DTC.Section{..} ->
52 xmlCommonAttrs attrs $
53 XML.section $ do
54 xmlTitle title
55 forM_ aliases xmlAlias
56 xmlBody ts
57 DTC.ToC{..} ->
58 xmlCommonAttrs attrs $
59 XML.toc
60 !?? mayAttr XA.depth depth
61 DTC.ToF{..} ->
62 xmlCommonAttrs attrs $
63 XML.tof $
64 XML.ul $
65 forM_ types $
66 XML.li . xmlText
67 DTC.Index{..} ->
68 xmlCommonAttrs attrs $
69 XML.index $ do
70 XML.ul $
71 forM_ terms $ \aliases ->
72 XML.li $
73 xmlText $
74 TL.unlines $
75 plainifyWords <$> aliases
76 DTC.Figure{..} ->
77 xmlCommonAttrs attrs $
78 XML.figure
79 ! XA.type_ (attrify type_) $ do
80 forM_ mayTitle xmlTitle
81 xmlBlocks blocks
82 DTC.References{..} ->
83 xmlCommonAttrs attrs $
84 XML.references $ forM_ refs $ xmlReference
85 DTC.Block v -> xmlBlock v
86
87 xmlAbout :: DTC.About -> XML
88 xmlAbout DTC.About{..} = do
89 forM_ titles $ xmlTitle
90 forM_ authors $ xmlEntity
91 forM_ editor $ xmlEntity
92 forM_ date $ xmlDate
93 whenMayText version xmlVersion
94 forM_ keywords $ xmlKeyword
95 forM_ links $ xmlLink
96 forM_ includes $ xmlInclude
97
98 xmlInclude :: DTC.Include -> XML
99 xmlInclude DTC.Include{..} =
100 XML.include True
101 ! XA.href (attrify href)
102
103 xmlKeyword :: TL.Text -> XML
104 xmlKeyword = XML.keyword . xmlText
105
106 xmlVersion :: MayText -> XML
107 xmlVersion (MayText t) = XML.version $ xmlText t
108
109 xmlDate :: DTC.Date -> XML
110 xmlDate DTC.Date{..} =
111 XML.date
112 ! XA.year (attrify year)
113 !?? mayAttr XA.month month
114 !?? mayAttr XA.day day
115
116 xmlLink :: DTC.Link -> XML
117 xmlLink DTC.Link{..} =
118 XML.link
119 !?? mayAttr XA.name name
120 !?? mayAttr XA.rel rel
121 !?? mayAttr XA.href href
122 $ xmlPara para
123
124 xmlEntity :: DTC.Entity -> XML
125 xmlEntity DTC.Entity{..} =
126 XML.entity
127 !?? mayAttr XA.name name
128 !?? mayAttr XA.street street
129 !?? mayAttr XA.zipcode zipcode
130 !?? mayAttr XA.city city
131 !?? mayAttr XA.region region
132 !?? mayAttr XA.country country
133 !?? mayAttr XA.email email
134 !?? mayAttr XA.tel tel
135 !?? mayAttr XA.fax fax
136
137 xmlTitle :: DTC.Title -> XML
138 xmlTitle (DTC.Title t) = XML.title $ xmlPara t
139
140 xmlAlias :: DTC.Alias -> XML
141 xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
142
143 xmlId :: DTC.Ident -> B.Attribute
144 xmlId (DTC.Ident i) = XA.id $ attrify i
145
146 xmlBlocks :: DTC.Blocks -> XML
147 xmlBlocks = (`forM_` xmlBlock)
148
149 xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
150 xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
151 (case ident of
152 Nothing -> \m -> m
153 Just (DTC.Ident i) ->
154 B.AddCustomAttribute "id" $
155 B.String $ TL.unpack i) .
156 case classes of
157 [] -> \m -> m
158 _ ->
159 B.AddCustomAttribute "class" $
160 B.String $ TL.unpack $ TL.unwords classes
161
162 xmlBlock :: DTC.Block -> XML
163 xmlBlock = \case
164 DTC.Para{..} ->
165 xmlCommonAttrs attrs $
166 XML.para $ xmlPara para
167 DTC.OL{..} ->
168 xmlCommonAttrs attrs $
169 XML.ol $ forM_ items $ XML.li . xmlBlocks
170 DTC.UL{..} ->
171 xmlCommonAttrs attrs $
172 XML.ul $ forM_ items $ XML.li . xmlBlocks
173 DTC.Comment c ->
174 XML.comment $ TL.toStrict c
175 DTC.Artwork{..} ->
176 xmlCommonAttrs attrs $
177 XML.artwork
178 ! XA.type_ (attrify type_) $ do
179 xmlText text
180 DTC.Quote{..} ->
181 xmlCommonAttrs attrs $
182 XML.quote
183 ! XA.type_ (attrify type_) $ do
184 xmlBlocks blocks
185
186 xmlPara :: DTC.Para -> XML
187 xmlPara = (`forM_` xmlLine)
188
189 xmlLine :: DTC.Lines -> XML
190 xmlLine (Tree n ls) =
191 case n of
192 DTC.Plain p -> B.toMarkup p
193 DTC.BR -> XML.br
194 DTC.B -> XML.b $ xmlPara ls
195 DTC.Code -> XML.code $ xmlPara ls
196 DTC.Del -> XML.del $ xmlPara ls
197 DTC.I -> XML.i $ xmlPara ls
198 DTC.Note{..} -> XML.note $ xmlPara ls
199 DTC.Q -> XML.q $ xmlPara ls
200 DTC.SC -> XML.sc $ xmlPara ls
201 DTC.Sub -> XML.sub $ xmlPara ls
202 DTC.Sup -> XML.sup $ xmlPara ls
203 DTC.U -> XML.u $ xmlPara ls
204 DTC.Eref to -> XML.eref ! XA.to (attrify to) $ xmlPara ls
205 DTC.Iref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlPara ls
206 DTC.Ref to -> XML.ref ! XA.to (attrify to) $ xmlPara ls
207 DTC.Rref{..} -> XML.rref ! XA.to (attrify to) $ xmlPara ls
208
209 xmlReference :: DTC.Reference -> XML
210 xmlReference DTC.Reference{..} =
211 XML.reference mempty