1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE DuplicateRecordFields #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Hdoc.DTC.Sym where
6 import Data.Bool (Bool(..))
7 import Control.Applicative (Applicative(..), (<$>), (<$))
8 import Control.Monad (void)
9 import Data.Default.Class (Default(..))
10 import Data.Foldable (Foldable(..), concat)
11 import Data.Function (($), (.))
12 import Data.Maybe (Maybe(..))
13 import Data.TreeSeq.Strict (Tree(..), tree0)
14 import qualified Control.Applicative as Alt
15 import qualified Data.Sequence as Seq
16 import qualified Data.Text.Lazy as TL
19 import Hdoc.RNC.Sym as RNC
20 import Hdoc.DTC.Index (wordify)
21 import qualified Hdoc.DTC.Document as DTC
22 import qualified Hdoc.RNC.Write as RNC
25 -- | Use a symantic (tagless final) class to encode
26 -- both the parsing and the schema of DTC,
27 -- when repr is respectively instanciated
28 -- on 'DTC.Parser' or 'RNC.RuleWriter'.
29 class RNC.Sym_RNC repr => Sym_DTC repr where
30 position :: repr DTC.Pos
31 document :: repr DTC.Document
34 about :: repr DTC.About
35 header :: repr DTC.Header
39 include :: repr DTC.Include
41 block :: repr DTC.Block
42 blockBreak :: repr DTC.Block
43 blockToC :: repr DTC.Block
44 blockToF :: repr DTC.Block
45 blockIndex :: repr DTC.Block
46 blockAside :: repr DTC.Block
47 blockFigure :: repr DTC.Block
48 blockReferences :: repr DTC.Block
49 blockJudges :: repr DTC.Block
50 blockGrades :: repr DTC.Block
51 reference :: repr DTC.Reference
54 paraItem :: repr DTC.ParaItem
55 paraItems :: repr DTC.Para
57 plain :: repr DTC.Plain
58 plainNode :: repr (Tree DTC.PlainNode)
60 commonAttrs :: repr DTC.CommonAttrs
62 title :: repr DTC.Title
68 class_ :: repr [TL.Text]
70 author :: repr DTC.Entity
71 editor :: repr DTC.Entity
73 entity :: repr DTC.Entity
75 serie :: repr DTC.Serie
76 alias :: repr DTC.Alias
77 judgment :: repr DTC.Judgment
78 choice_ :: repr DTC.Choice
79 opinion :: repr DTC.Opinion
80 judge :: repr DTC.Judge
81 grade :: repr DTC.Grade
83 document = rule "document" $
90 <$?> (def, rule "about" $ element "about" about)
97 [ element "section" $ Tree <$> section <*> body
98 , tree0 . DTC.BodyBlock <$> block
108 title = rule "title" $ DTC.Title <$> element "title" plain
109 name = rule "name" $ DTC.Name <$> text
110 url = rule "url" $ URL <$> text
111 path = rule "path" $ Path <$> text
112 ident = rule "ident" $ Ident <$> text
113 to = rule "to" $ attribute "to" ident
118 <$?> (def, Just <$> id)
120 id = rule "id" $ attribute "id" ident
121 class_ = rule "class" $ attribute "class" $ TL.words <$> text
126 <$?> (0, attribute "year" int)
127 <|?> (Nothing, Just <$> attribute "month" nat1)
128 <|?> (Nothing, Just <$> attribute "day" nat1)
134 <$?> (def, attribute "href" path)
135 block = rule "block" $
137 [ DTC.BlockPara <$> para
148 , anyElem $ \n@XmlName{..} ->
153 blockBreak = rule "break" $
163 <*> optional (attribute "depth" nat)
188 (wordify <$>) . TL.lines <$> text)
201 <*> attribute "type" text
206 rule "blockReferences" $
207 element "references" $
231 <*> attribute "name" name
232 <*> attribute "color" text
233 <*> option False (True <$ attribute "default" text)
237 paraItems <|> -- within a <para>
238 DTC.ParaItem <$> paraItem -- without a <para>
242 [ element "ol" $ DTC.ParaOL <$> many (element "li" $ DTC.ListItem <$> attribute "name" name <*> many para)
243 , element "ul" $ DTC.ParaUL <$> many (element "li" $ many para)
244 , element "artwork" $ DTC.ParaArtwork <$> attribute "type" text <*> text
245 , element "quote" $ DTC.ParaQuote <$> attribute "type" text <*> many para
246 , DTC.ParaPlain . Seq.fromList <$> some plainNode
247 , DTC.ParaComment <$> comment
248 , DTC.ParaJudgment <$> judgment
257 plain = rule "plain" $ (Seq.fromList <$>) $ many plainNode
261 [ tree0 . DTC.PlainText <$> text
262 , element "br" $ tree0 DTC.PlainBreak <$ none
263 , element "b" $ Tree DTC.PlainB <$> plain
264 , element "code" $ Tree DTC.PlainCode <$> plain
265 , element "del" $ Tree DTC.PlainDel <$> plain
266 , element "i" $ Tree DTC.PlainI <$> plain
267 , element "q" $ Tree DTC.PlainQ <$> plain
268 , element "sc" $ Tree DTC.PlainSC <$> plain
269 , element "span" $ Tree . DTC.PlainSpan <$> commonAttrs <*> plain
270 , element "sub" $ Tree DTC.PlainSub <$> plain
271 , element "sup" $ Tree DTC.PlainSup <$> plain
272 , element "u" $ Tree DTC.PlainU <$> plain
273 , element "note" $ tree0 . DTC.PlainNote Nothing <$> many para
274 , element "iref" $ Tree . DTC.PlainIref Nothing . wordify <$> attribute "to" text <*> plain
275 , element "eref" $ Tree . DTC.PlainEref <$> attribute "to" url <*> plain
276 , element "ref" $ Tree . DTC.PlainRef <$> to <*> plain
277 , element "rref" $ Tree . DTC.PlainRref Nothing <$> to <*> plain
279 tag = rule "tag" $ element "tag" text
281 (foldr ($) def <$>) $
283 [ (\a acc -> acc{DTC.titles=a:DTC.titles acc}) <$> title
284 , (\a acc -> (acc::DTC.About){DTC.url=Just a}) <$> attribute "url" url
285 , (\a acc -> acc{DTC.authors=a:DTC.authors acc}) <$> author
286 , (\a acc -> acc{DTC.editor=DTC.editor acc Alt.<|> Just a}) <$> editor
287 , (\a acc -> acc{DTC.date=DTC.date acc Alt.<|> Just a}) <$> date
288 , (\a acc -> acc{DTC.tags=a:DTC.tags acc}) <$> tag
289 , (\a acc -> acc{DTC.links=a:DTC.links acc}) <$> link
290 , (\a acc -> acc{DTC.series=a:DTC.series acc}) <$> serie
291 , (\a acc -> acc{DTC.headers=a:DTC.headers acc}) <$> header
296 DTC.Header (xmlNameLocal n)
298 author = rule "author" $ element "author" entity
299 editor = rule "editor" $ element "editor" entity
300 entity = rule "entity" $
303 <$?> (def, attribute "name" text)
304 <|?> (def, attribute "street" text)
305 <|?> (def, attribute "zipcode" text)
306 <|?> (def, attribute "city" text)
307 <|?> (def, attribute "region" text)
308 <|?> (def, attribute "country" text)
309 <|?> (def, attribute "email" text)
310 <|?> (def, attribute "tel" text)
311 <|?> (def, attribute "fax" text)
312 <|?> (def, Just <$> attribute "url" url)
313 <|?> (def, Just <$> element "org" entity)
314 serie = rule "serie" $
318 <$?> (def, attribute "name" name)
319 <|?> (def, attribute "id" text)
323 (\n h r t p -> DTC.Link n h r t (Seq.fromList p))
324 <$?> (def, attribute "name" name)
325 <|?> (def, attribute "href" url)
326 <|?> (def, attribute "rel" text)
327 <|?> (def, Just <$> attribute "type" text)
329 alias = rule "alias" $
334 reference = rule "reference" $
335 element "reference" $
349 <$$> attribute "judges" ident
350 <||> attribute "grades" ident
351 <|?> (def, Just <$> attribute "importance" rationalPositive)
352 <|?> (def, Just <$> title)
362 (interleaved $ DTC.Opinion
363 <$?> (def, attribute "judge" name)
364 <|?> (def, attribute "grade" name)
365 <|?> (def, Just <$> attribute "importance" rationalPositive))
371 <$> attribute "name" name
373 <*> many defaultGrade
379 <$> attribute "grades" ident
380 <*> attribute "grade" (DTC.Name <$> text)
382 instance Sym_DTC RNC.Writer where
383 position = RNC.writeText ""
384 instance Sym_DTC RNC.RuleWriter where
385 position = RNC.RuleWriter position
387 -- | RNC schema for DTC
388 schema :: [RNC.RuleWriter ()]
393 , void $ rule "about" $ element "about" about
417 , void $ blockReferences