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