]> Git — Sourcephile - doclang.git/blob - Language/DTC/Sym.hs
Add better support for HeaderDotSlash including.
[doclang.git] / Language / DTC / Sym.hs
1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE DuplicateRecordFields #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Language.DTC.Sym where
5
6 import Control.Applicative (Applicative(..), (<$>), (<$))
7 import Control.Monad (void)
8 import Data.Default.Class (Default(..))
9 import Data.Foldable (Foldable(..), concat)
10 import Data.Function (($), (.), flip)
11 import Data.Maybe (Maybe(..), maybe)
12 import Data.TreeSeq.Strict (Tree(..), tree0)
13 import qualified Data.Sequence as Seq
14 import qualified Data.Text.Lazy as TL
15
16 import Language.XML
17 import Language.RNC.Sym as RNC
18 import Language.DTC.Anchor (wordify)
19 import qualified Language.DTC.Document as DTC
20 import qualified Language.RNC.Write as RNC
21
22 foldlApp :: (Default a, Foldable t) => t (a -> a) -> a
23 foldlApp = foldl' (flip ($)) def
24 foldrApp :: (Default a, Foldable t) => t (a -> a) -> a
25 foldrApp = foldr ($) def
26
27 -- Class 'Sym_DTC'
28 -- | Use a symantic (tagless final) class to encode
29 -- both the parsing and the schema of DTC,
30 -- when repr is respectively instanciated
31 -- on 'DTC.Parser' or 'RNC.RuleWriter'.
32 class RNC.Sym_RNC repr => Sym_DTC repr where
33 position :: repr DTC.Pos
34 document :: repr DTC.Document
35
36 head :: repr DTC.Head
37 about :: repr DTC.About
38 header :: repr DTC.Header
39 tag :: repr TL.Text
40 author :: repr DTC.Entity
41 editor :: repr DTC.Entity
42 date :: repr DTC.Date
43 entity :: repr DTC.Entity
44 link :: repr DTC.Link
45 serie :: repr DTC.Serie
46 alias :: repr DTC.Alias
47
48 body :: repr DTC.Body
49 include :: repr DTC.Include
50
51 block :: repr DTC.Block
52 blockToC :: repr DTC.Block
53 blockToF :: repr DTC.Block
54 blockIndex :: repr DTC.Block
55 blockFigure :: repr DTC.Block
56 blockReferences :: repr DTC.Block
57 reference :: repr DTC.Reference
58
59 para :: repr DTC.Para
60 paraItem :: repr DTC.ParaItem
61 paraItems :: repr DTC.Para
62
63 plain :: repr DTC.Plain
64 plainNode :: repr (Tree DTC.PlainNode)
65
66 commonAttrs :: repr DTC.CommonAttrs
67 ident :: repr Ident
68 title :: repr DTC.Title
69 name :: repr TL.Text
70 url :: repr URL
71 path :: repr Path
72 to :: repr Ident
73 id :: repr Ident
74
75 commonAttrs =
76 rule "commonAttrs" $
77 interleaved $
78 DTC.CommonAttrs
79 <$?> (def, Just <$> id)
80 <|?> (def, rule "class" $ attribute "class" $ TL.words <$> text)
81
82 document = rule "document" $
83 DTC.Document
84 <$> head
85 <*> body
86 head = rule "head" $
87 maybe def DTC.Head
88 <$> optional (rule "about" $ element "about" about)
89 body =
90 rule "body" $
91 (Seq.fromList <$>) $
92 many $
93 choice
94 [ element "section" $ Tree <$> section <*> body
95 , tree0 . DTC.BodyBlock <$> block
96 ]
97 where
98 section =
99 DTC.BodySection
100 <$> position
101 <*> commonAttrs
102 <*> title
103 <*> many alias
104 title = rule "title" $ DTC.Title <$> element "title" plain
105 name = rule "name" $ attribute "name" text
106 url = rule "url" $ URL <$> text
107 path = rule "path" $ Path <$> text
108 ident = rule "ident" $ Ident <$> text
109 to = rule "to" $ attribute "to" ident
110 id = rule "id" $ attribute "id" ident
111 date = rule "date" $
112 element "date" $
113 interleaved $
114 DTC.Date
115 <$?> (0, attribute "year" int)
116 <|?> (Nothing, Just <$> attribute "month" nat1)
117 <|?> (Nothing, Just <$> attribute "day" nat1)
118 include =
119 rule "include" $
120 element "include" $
121 interleaved $
122 DTC.Include
123 <$?> (def, attribute "href" path)
124 block = rule "block" $
125 choice
126 [ DTC.BlockPara <$> para
127 , blockToC
128 , blockToF
129 , blockIndex
130 , blockFigure
131 , blockReferences
132 {-
133 , anyElem $ \n@XmlName{..} ->
134 case xmlNameSpace of
135 "" -> figure n
136 -}
137 ]
138 blockToC =
139 rule "blockToC" $
140 element "toc" $
141 DTC.BlockToC
142 <$> position
143 <*> commonAttrs
144 <*> optional (attribute "depth" nat)
145 blockToF =
146 rule "blockToF" $
147 element "tof" $
148 DTC.BlockToF
149 <$> position
150 <*> commonAttrs
151 <*> option [] (
152 element "ul" $
153 many $
154 element "li" $
155 element "para" text)
156 blockIndex =
157 rule "blockIndex" $
158 element "index" $
159 DTC.BlockIndex
160 <$> position
161 <*> commonAttrs
162 <*> option [] (
163 element "ul" $
164 many $
165 element "li" $
166 element "para" $
167 (concat <$>) $
168 many $
169 (wordify <$>) . TL.lines <$> text)
170 blockFigure =
171 rule "blockFigure" $
172 element "figure" $
173 DTC.BlockFigure
174 <$> position
175 <*> commonAttrs
176 <*> attribute "type" text
177 <*> optional title
178 <*> many para
179 blockReferences =
180 rule "blockReferences" $
181 element "references" $
182 DTC.BlockReferences
183 <$> position
184 <*> commonAttrs
185 <*> many reference
186
187 para = rule "para" $ paraItems <|> DTC.ParaItem <$> paraItem
188 paraItem =
189 rule "paraItem" $
190 choice
191 [ element "ol" $ DTC.ParaOL <$> many (element "li" $ DTC.ListItem <$> attribute "name" text <*> many para)
192 , element "ul" $ DTC.ParaUL <$> many (element "li" $ many para)
193 , element "artwork" $ DTC.ParaArtwork <$> attribute "type" text <*> text
194 , element "quote" $ DTC.ParaQuote <$> attribute "type" text <*> many para
195 , DTC.ParaPlain . Seq.fromList <$> some plainNode
196 , DTC.ParaComment <$> comment
197 ]
198 paraItems =
199 rule "paraItems" $
200 element "para" $
201 DTC.ParaItems
202 <$> position
203 <*> commonAttrs
204 <*> many paraItem
205 plain = rule "plain" $ (Seq.fromList <$>) $ many plainNode
206 plainNode =
207 rule "plainNode" $
208 choice
209 [ tree0 . DTC.PlainText <$> text
210 , element "br" $ tree0 DTC.PlainBR <$ none
211 , element "b" $ Tree DTC.PlainB <$> plain
212 , element "code" $ Tree DTC.PlainCode <$> plain
213 , element "del" $ Tree DTC.PlainDel <$> plain
214 , element "i" $ Tree DTC.PlainI <$> plain
215 , element "q" $ Tree DTC.PlainQ <$> plain
216 , element "sc" $ Tree DTC.PlainSC <$> plain
217 , element "sub" $ Tree DTC.PlainSub <$> plain
218 , element "sup" $ Tree DTC.PlainSup <$> plain
219 , element "u" $ Tree DTC.PlainU <$> plain
220 , element "note" $ tree0 . DTC.PlainNote Nothing <$> many para
221 , element "iref" $ Tree . DTC.PlainIref Nothing . wordify <$> attribute "to" text <*> plain
222 , element "eref" $ Tree . DTC.PlainEref <$> attribute "to" url <*> plain
223 , element "ref" $ Tree . DTC.PlainRef <$> to <*> plain
224 , element "rref" $ Tree . DTC.PlainRref Nothing <$> to <*> plain
225 ]
226 tag = rule "tag" $ element "tag" text
227 about =
228 (foldl' (flip ($)) def <$>) $
229 many $ choice
230 [ (\a acc -> acc{DTC.titles=a:DTC.titles acc}) <$> title
231 , (\a acc -> (acc::DTC.About){DTC.url=Just a}) <$> attribute "url" url
232 , (\a acc -> acc{DTC.authors=a:DTC.authors acc}) <$> author
233 , (\a acc -> acc{DTC.editor=Just a}) <$> editor
234 , (\a acc -> acc{DTC.date=Just a}) <$> date
235 , (\a acc -> acc{DTC.tags=a:DTC.tags acc}) <$> tag
236 , (\a acc -> acc{DTC.links=a:DTC.links acc}) <$> link
237 , (\a acc -> acc{DTC.series=a:DTC.series acc}) <$> serie
238 , (\a acc -> acc{DTC.headers=a:DTC.headers acc}) <$> header
239 ]
240 header =
241 rule "header" $
242 anyElem $ \n ->
243 DTC.Header (xmlNameLocal n)
244 <$> plain
245 author = rule "author" $ element "author" entity
246 editor = rule "editor" $ element "editor" entity
247 entity = rule "entity" $
248 interleaved $
249 DTC.Entity
250 <$?> (def, name)
251 <|?> (def, attribute "street" text)
252 <|?> (def, attribute "zipcode" text)
253 <|?> (def, attribute "city" text)
254 <|?> (def, attribute "region" text)
255 <|?> (def, attribute "country" text)
256 <|?> (def, attribute "email" text)
257 <|?> (def, attribute "tel" text)
258 <|?> (def, attribute "fax" text)
259 <|?> (def, Just <$> attribute "url" url)
260 <|?> (def, Just <$> element "org" entity)
261 serie = rule "serie" $
262 element "serie" $
263 interleaved $
264 DTC.Serie
265 <$?> (def, name)
266 <|?> (def, attribute "id" text)
267 link = rule "link" $
268 element "link" $
269 interleaved $
270 (\n h r t p -> DTC.Link n h r t (Seq.fromList p))
271 <$?> (def, name)
272 <|?> (def, attribute "href" url)
273 <|?> (def, attribute "rel" text)
274 <|?> (def, Just <$> attribute "type" text)
275 <|*> plainNode
276 alias = rule "alias" $
277 element "alias" $
278 interleaved $
279 DTC.Alias
280 <$?> (def, id)
281 reference = rule "reference" $
282 element "reference" $
283 DTC.Reference
284 <$> id
285 <*> about
286
287 instance Sym_DTC RNC.Writer where
288 position = RNC.writeText ""
289 instance Sym_DTC RNC.RuleWriter where
290 position = RNC.RuleWriter position
291
292 -- | RNC schema for DTC
293 schema :: [RNC.RuleWriter ()]
294 schema =
295 [ void $ document
296
297 , void $ head
298 , void $ rule "about" $ element "about" about
299 , void $ header
300 , void $ tag
301 , void $ author
302 , void $ editor
303 , void $ date
304 , void $ entity
305 , void $ link
306 , void $ serie
307 , void $ alias
308
309 , void $ body
310 , void $ include
311
312 , void $ block
313 , void $ blockToC
314 , void $ blockToF
315 , void $ blockIndex
316 , void $ blockFigure
317 , void $ blockReferences
318 , void $ reference
319
320 , void $ para
321 , void $ paraItem
322 , void $ paraItems
323
324 , void $ plain
325 , void $ plainNode
326
327 , void $ commonAttrs
328 , void $ ident
329 , void $ title
330 , void $ name
331 , void $ url
332 , void $ path
333 , void $ to
334 , void $ id
335 ]