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