aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/Util
diff options
context:
space:
mode:
authorJohannes Gerer <oss@johannesgerer.com>2016-10-26 02:07:02 +0200
committerJohannes Gerer <oss@johannesgerer.com>2016-10-26 02:07:02 +0200
commit675085c2e0b0b851378da08b7d73024766107c87 (patch)
tree5a927de4a9576aef7e6129b96e74aa5c96f9ffb6 /src/Util
downloadblazeT-675085c2e0b0b851378da08b7d73024766107c87.tar.gz
blazeT-675085c2e0b0b851378da08b7d73024766107c87.tar.zst
blazeT-675085c2e0b0b851378da08b7d73024766107c87.zip
Initial
Diffstat (limited to 'src/Util')
-rw-r--r--src/Util/GenerateHtmlCombinators.hs519
-rwxr-xr-xsrc/Util/GenerateHtmlTCombinators.hs62
-rw-r--r--src/Util/Sanitize.hs112
3 files changed, 693 insertions, 0 deletions
diff --git a/src/Util/GenerateHtmlCombinators.hs b/src/Util/GenerateHtmlCombinators.hs
new file mode 100644
index 0000000..83da65b
--- /dev/null
+++ b/src/Util/GenerateHtmlCombinators.hs
@@ -0,0 +1,519 @@
1-- taken from https://github.com/jaspervdj/blaze-html/blob/2c4513e30ce768517b8d7b7b154d438f55217006/src/Util/GenerateHtmlCombinators.hs
2
3-- Copyright Jasper Van der Jeugt 2010
4
5-- All rights reserved.
6
7-- Redistribution and use in source and binary forms, with or without
8-- modification, are permitted provided that the following conditions are met:
9
10-- * Redistributions of source code must retain the above copyright
11-- notice, this list of conditions and the following disclaimer.
12
13-- * Redistributions in binary form must reproduce the above
14-- copyright notice, this list of conditions and the following
15-- disclaimer in the documentation and/or other materials provided
16-- with the distribution.
17
18-- * Neither the name of Jasper Van der Jeugt nor the names of other
19-- contributors may be used to endorse or promote products derived
20-- from this software without specific prior written permission.
21
22-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
25-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
26-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
27-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
28-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
29-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
30-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
31-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
32-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33
34{-# LANGUAGE CPP #-}
35
36#define DO_NOT_EDIT (doNotEdit __FILE__ __LINE__)
37
38-- | Generates code for HTML tags.
39--
40module Util.GenerateHtmlCombinators where
41
42import Control.Arrow ((&&&))
43import Data.List (sort, sortBy, intersperse, intercalate)
44import Data.Ord (comparing)
45import System.Directory (createDirectoryIfMissing)
46import System.FilePath ((</>), (<.>))
47import Data.Map (Map)
48import qualified Data.Map as M
49import Data.Char (toLower)
50import qualified Data.Set as S
51
52import Util.Sanitize (sanitize, prelude)
53
54-- | Datatype for an HTML variant.
55--
56data HtmlVariant = HtmlVariant
57 { version :: [String]
58 , docType :: [String]
59 , parents :: [String]
60 , leafs :: [String]
61 , attributes :: [String]
62 , selfClosing :: Bool
63 } deriving (Eq)
64
65instance Show HtmlVariant where
66 show = map toLower . intercalate "-" . version
67
68-- | Get the full module name for an HTML variant.
69--
70getModuleName :: HtmlVariant -> String
71getModuleName = ("Text.Blaze." ++) . intercalate "." . version
72
73-- | Get the attribute module name for an HTML variant.
74--
75getAttributeModuleName :: HtmlVariant -> String
76getAttributeModuleName = (++ ".Attributes") . getModuleName
77
78-- | Check if a given name causes a name clash.
79--
80isNameClash :: HtmlVariant -> String -> Bool
81isNameClash v t
82 -- Both an element and an attribute
83 | (t `elem` parents v || t `elem` leafs v) && t `elem` attributes v = True
84 -- Already a prelude function
85 | sanitize t `S.member` prelude = True
86 | otherwise = False
87
88-- | Write an HTML variant.
89--
90writeHtmlVariant :: HtmlVariant -> IO ()
91writeHtmlVariant htmlVariant = do
92 -- Make a directory.
93 createDirectoryIfMissing True basePath
94
95 let tags = zip parents' (repeat makeParent)
96 ++ zip leafs' (repeat (makeLeaf $ selfClosing htmlVariant))
97 sortedTags = sortBy (comparing fst) tags
98 appliedTags = map (\(x, f) -> f x) sortedTags
99
100 -- Write the main module.
101 writeFile' (basePath <.> "hs") $ removeTrailingNewlines $ unlines
102 [ DO_NOT_EDIT
103 , "{-# LANGUAGE OverloadedStrings #-}"
104 , "-- | This module exports HTML combinators used to create documents."
105 , "--"
106 , exportList modulName $ "module Text.Blaze.Html"
107 : "docType"
108 : "docTypeHtml"
109 : map (sanitize . fst) sortedTags
110 , DO_NOT_EDIT
111 , "import Prelude ((>>), (.))"
112 , ""
113 , "import Text.Blaze"
114 , "import Text.Blaze.Internal"
115 , "import Text.Blaze.Html"
116 , ""
117 , makeDocType $ docType htmlVariant
118 , makeDocTypeHtml $ docType htmlVariant
119 , unlines appliedTags
120 ]
121
122 let sortedAttributes = sort attributes'
123
124 -- Write the attribute module.
125 writeFile' (basePath </> "Attributes.hs") $ removeTrailingNewlines $ unlines
126 [ DO_NOT_EDIT
127 , "-- | This module exports combinators that provide you with the"
128 , "-- ability to set attributes on HTML elements."
129 , "--"
130 , "{-# LANGUAGE OverloadedStrings #-}"
131 , exportList attributeModuleName $ map sanitize sortedAttributes
132 , DO_NOT_EDIT
133 , "import Prelude ()"
134 , ""
135 , "import Text.Blaze.Internal (Attribute, AttributeValue, attribute)"
136 , ""
137 , unlines (map makeAttribute sortedAttributes)
138 ]
139 where
140 basePath = "src" </> "Text" </> "Blaze" </> foldl1 (</>) version'
141 modulName = getModuleName htmlVariant
142 attributeModuleName = getAttributeModuleName htmlVariant
143 attributes' = attributes htmlVariant
144 parents' = parents htmlVariant
145 leafs' = leafs htmlVariant
146 version' = version htmlVariant
147 removeTrailingNewlines = reverse . drop 2 . reverse
148 writeFile' file content = do
149 putStrLn ("Generating " ++ file)
150 writeFile file content
151
152-- | Create a string, consisting of @x@ spaces, where @x@ is the length of the
153-- argument.
154--
155spaces :: String -> String
156spaces = flip replicate ' ' . length
157
158-- | Join blocks of code with a newline in between.
159--
160unblocks :: [String] -> String
161unblocks = unlines . intersperse "\n"
162
163-- | A warning to not edit the generated code.
164--
165doNotEdit :: FilePath -> Int -> String
166doNotEdit fileName lineNumber = init $ unlines
167 [ "-- WARNING: The next block of code was automatically generated by"
168 , "-- " ++ fileName ++ ":" ++ show lineNumber
169 , "--"
170 ]
171
172-- | Generate an export list for a Haskell module.
173--
174exportList :: String -- ^ Module name.
175 -> [String] -- ^ List of functions.
176 -> String -- ^ Resulting string.
177exportList _ [] = error "exportList without functions."
178exportList name (f:functions) = unlines $
179 [ "module " ++ name
180 , " ( " ++ f
181 ] ++
182 map (" , " ++) functions ++
183 [ " ) where"]
184
185-- | Generate a function for a doctype.
186--
187makeDocType :: [String] -> String
188makeDocType lines' = unlines
189 [ DO_NOT_EDIT
190 , "-- | Combinator for the document type. This should be placed at the top"
191 , "-- of every HTML page."
192 , "--"
193 , "-- Example:"
194 , "--"
195 , "-- > docType"
196 , "--"
197 , "-- Result:"
198 , "--"
199 , unlines (map ("-- > " ++) lines') ++ "--"
200 , "docType :: Html -- ^ The document type HTML."
201 , "docType = preEscapedText " ++ show (unlines lines')
202 , "{-# INLINE docType #-}"
203 ]
204
205-- | Generate a function for the HTML tag (including the doctype).
206--
207makeDocTypeHtml :: [String] -- ^ The doctype.
208 -> String -- ^ Resulting combinator function.
209makeDocTypeHtml lines' = unlines
210 [ DO_NOT_EDIT
211 , "-- | Combinator for the @\\<html>@ element. This combinator will also"
212 , "-- insert the correct doctype."
213 , "--"
214 , "-- Example:"
215 , "--"
216 , "-- > docTypeHtml $ span $ toHtml \"foo\""
217 , "--"
218 , "-- Result:"
219 , "--"
220 , unlines (map ("-- > " ++) lines') ++ "-- > <html><span>foo</span></html>"
221 , "--"
222 , "docTypeHtml :: Html -- ^ Inner HTML."
223 , " -> Html -- ^ Resulting HTML."
224 , "docTypeHtml inner = docType >> html inner"
225 , "{-# INLINE docTypeHtml #-}"
226 ]
227
228-- | Generate a function for an HTML tag that can be a parent.
229--
230makeParent :: String -> String
231makeParent tag = unlines
232 [ DO_NOT_EDIT
233 , "-- | Combinator for the @\\<" ++ tag ++ ">@ element."
234 , "--"
235 , "-- Example:"
236 , "--"
237 , "-- > " ++ function ++ " $ span $ toHtml \"foo\""
238 , "--"
239 , "-- Result:"
240 , "--"
241 , "-- > <" ++ tag ++ "><span>foo</span></" ++ tag ++ ">"
242 , "--"
243 , function ++ " :: Html -- ^ Inner HTML."
244 , spaces function ++ " -> Html -- ^ Resulting HTML."
245 , function ++ " = Parent \"" ++ tag ++ "\" \"<" ++ tag
246 ++ "\" \"</" ++ tag ++ ">\"" ++ modifier
247 , "{-# INLINE " ++ function ++ " #-}"
248 ]
249 where
250 function = sanitize tag
251 modifier = if tag `elem` ["style", "script"] then " . external" else ""
252
253-- | Generate a function for an HTML tag that must be a leaf.
254--
255makeLeaf :: Bool -- ^ Make leaf tags self-closing
256 -> String -- ^ Tag for the combinator
257 -> String -- ^ Combinator code
258makeLeaf closing tag = unlines
259 [ DO_NOT_EDIT
260 , "-- | Combinator for the @\\<" ++ tag ++ " />@ element."
261 , "--"
262 , "-- Example:"
263 , "--"
264 , "-- > " ++ function
265 , "--"
266 , "-- Result:"
267 , "--"
268 , "-- > <" ++ tag ++ " />"
269 , "--"
270 , function ++ " :: Html -- ^ Resulting HTML."
271 , function ++ " = Leaf \"" ++ tag ++ "\" \"<" ++ tag ++ "\" " ++ "\""
272 ++ (if closing then " /" else "") ++ ">\""
273 , "{-# INLINE " ++ function ++ " #-}"
274 ]
275 where
276 function = sanitize tag
277
278-- | Generate a function for an HTML attribute.
279--
280makeAttribute :: String -> String
281makeAttribute name = unlines
282 [ DO_NOT_EDIT
283 , "-- | Combinator for the @" ++ name ++ "@ attribute."
284 , "--"
285 , "-- Example:"
286 , "--"
287 , "-- > div ! " ++ function ++ " \"bar\" $ \"Hello.\""
288 , "--"
289 , "-- Result:"
290 , "--"
291 , "-- > <div " ++ name ++ "=\"bar\">Hello.</div>"
292 , "--"
293 , function ++ " :: AttributeValue -- ^ Attribute value."
294 , spaces function ++ " -> Attribute -- ^ Resulting attribute."
295 , function ++ " = attribute \"" ++ name ++ "\" \" "
296 ++ name ++ "=\\\"\""
297 , "{-# INLINE " ++ function ++ " #-}"
298 ]
299 where
300 function = sanitize name
301
302-- | HTML 4.01 Strict.
303-- A good reference can be found here: http://www.w3schools.com/tags/default.asp
304--
305html4Strict :: HtmlVariant
306html4Strict = HtmlVariant
307 { version = ["Html4", "Strict"]
308 , docType =
309 [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\""
310 , " \"http://www.w3.org/TR/html4/strict.dtd\">"
311 ]
312 , parents =
313 [ "a", "abbr", "acronym", "address", "b", "bdo", "big", "blockquote"
314 , "body" , "button", "caption", "cite", "code", "colgroup", "dd", "del"
315 , "dfn", "div" , "dl", "dt", "em", "fieldset", "form", "h1", "h2", "h3"
316 , "h4", "h5", "h6", "head", "html", "i", "ins" , "kbd", "label"
317 , "legend", "li", "map", "noscript", "object", "ol", "optgroup"
318 , "option", "p", "pre", "q", "samp", "script", "select", "small"
319 , "span", "strong", "style", "sub", "sup", "table", "tbody", "td"
320 , "textarea", "tfoot", "th", "thead", "title", "tr", "tt", "ul", "var"
321 ]
322 , leafs =
323 [ "area", "br", "col", "hr", "link", "img", "input", "meta", "param"
324 ]
325 , attributes =
326 [ "abbr", "accept", "accesskey", "action", "align", "alt", "archive"
327 , "axis", "border", "cellpadding", "cellspacing", "char", "charoff"
328 , "charset", "checked", "cite", "class", "classid", "codebase"
329 , "codetype", "cols", "colspan", "content", "coords", "data", "datetime"
330 , "declare", "defer", "dir", "disabled", "enctype", "for", "frame"
331 , "headers", "height", "href", "hreflang", "http-equiv", "id", "label"
332 , "lang", "maxlength", "media", "method", "multiple", "name", "nohref"
333 , "onabort", "onblur", "onchange", "onclick", "ondblclick", "onfocus"
334 , "onkeydown", "onkeypress", "onkeyup", "onload", "onmousedown"
335 , "onmousemove", "onmouseout", "onmouseover", "onmouseup", "onreset"
336 , "onselect", "onsubmit", "onunload", "profile", "readonly", "rel"
337 , "rev", "rows", "rowspan", "rules", "scheme", "scope", "selected"
338 , "shape", "size", "span", "src", "standby", "style", "summary"
339 , "tabindex", "title", "type", "usemap", "valign", "value", "valuetype"
340 , "width"
341 ]
342 , selfClosing = False
343 }
344
345-- | HTML 4.0 Transitional
346--
347html4Transitional :: HtmlVariant
348html4Transitional = HtmlVariant
349 { version = ["Html4", "Transitional"]
350 , docType =
351 [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\""
352 , " \"http://www.w3.org/TR/html4/loose.dtd\">"
353 ]
354 , parents = parents html4Strict ++
355 [ "applet", "center", "dir", "font", "iframe", "isindex", "menu"
356 , "noframes", "s", "u"
357 ]
358 , leafs = leafs html4Strict ++ ["basefont"]
359 , attributes = attributes html4Strict ++
360 [ "background", "bgcolor", "clear", "compact", "hspace", "language"
361 , "noshade", "nowrap", "start", "target", "vspace"
362 ]
363 , selfClosing = False
364 }
365
366-- | HTML 4.0 FrameSet
367--
368html4FrameSet :: HtmlVariant
369html4FrameSet = HtmlVariant
370 { version = ["Html4", "FrameSet"]
371 , docType =
372 [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 FrameSet//EN\""
373 , " \"http://www.w3.org/TR/html4/frameset.dtd\">"
374 ]
375 , parents = parents html4Transitional ++ ["frameset"]
376 , leafs = leafs html4Transitional ++ ["frame"]
377 , attributes = attributes html4Transitional ++
378 [ "frameborder", "scrolling"
379 ]
380 , selfClosing = False
381 }
382
383-- | XHTML 1.0 Strict
384--
385xhtml1Strict :: HtmlVariant
386xhtml1Strict = HtmlVariant
387 { version = ["XHtml1", "Strict"]
388 , docType =
389 [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\""
390 , " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
391 ]
392 , parents = parents html4Strict
393 , leafs = leafs html4Strict
394 , attributes = attributes html4Strict
395 , selfClosing = True
396 }
397
398-- | XHTML 1.0 Transitional
399--
400xhtml1Transitional :: HtmlVariant
401xhtml1Transitional = HtmlVariant
402 { version = ["XHtml1", "Transitional"]
403 , docType =
404 [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\""
405 , " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"
406 ]
407 , parents = parents html4Transitional
408 , leafs = leafs html4Transitional
409 , attributes = attributes html4Transitional
410 , selfClosing = True
411 }
412
413-- | XHTML 1.0 FrameSet
414--
415xhtml1FrameSet :: HtmlVariant
416xhtml1FrameSet = HtmlVariant
417 { version = ["XHtml1", "FrameSet"]
418 , docType =
419 [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 FrameSet//EN\""
420 , " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
421 ]
422 , parents = parents html4FrameSet
423 , leafs = leafs html4FrameSet
424 , attributes = attributes html4FrameSet
425 , selfClosing = True
426 }
427
428-- | HTML 5.0
429-- A good reference can be found here:
430-- http://www.w3schools.com/html5/html5_reference.asp
431--
432html5 :: HtmlVariant
433html5 = HtmlVariant
434 { version = ["Html5"]
435 , docType = ["<!DOCTYPE HTML>"]
436 , parents =
437 [ "a", "abbr", "address", "article", "aside", "audio", "b"
438 , "bdo", "blockquote", "body", "button", "canvas", "caption", "cite"
439 , "code", "colgroup", "command", "datalist", "dd", "del", "details"
440 , "dfn", "div", "dl", "dt", "em", "fieldset", "figcaption", "figure"
441 , "footer", "form", "h1", "h2", "h3", "h4", "h5", "h6", "head", "header"
442 , "hgroup", "html", "i", "iframe", "ins", "kbd", "label"
443 , "legend", "li", "main", "map", "mark", "menu", "meter", "nav"
444 , "noscript", "object", "ol", "optgroup", "option", "output", "p"
445 , "pre", "progress", "q", "rp", "rt", "ruby", "samp", "script"
446 , "section", "select", "small", "span", "strong", "style", "sub"
447 , "summary", "sup", "table", "tbody", "td", "textarea", "tfoot", "th"
448 , "thead", "time", "title", "tr", "ul", "var", "video"
449 ]
450 , leafs =
451 -- http://www.whatwg.org/specs/web-apps/current-work/multipage/syntax.html#void-elements
452 [ "area", "base", "br", "col", "embed", "hr", "img", "input", "keygen"
453 , "link", "menuitem", "meta", "param", "source", "track", "wbr"
454 ]
455 , attributes =
456 [ "accept", "accept-charset", "accesskey", "action", "alt", "async"
457 , "autocomplete", "autofocus", "autoplay", "challenge", "charset"
458 , "checked", "cite", "class", "cols", "colspan", "content"
459 , "contenteditable", "contextmenu", "controls", "coords", "data"
460 , "datetime", "defer", "dir", "disabled", "draggable", "enctype", "for"
461 , "form", "formaction", "formenctype", "formmethod", "formnovalidate"
462 , "formtarget", "headers", "height", "hidden", "high", "href"
463 , "hreflang", "http-equiv", "icon", "id", "ismap", "item", "itemprop"
464 , "itemscope", "itemtype"
465 , "keytype", "label", "lang", "list", "loop", "low", "manifest", "max"
466 , "maxlength", "media", "method", "min", "multiple", "name"
467 , "novalidate", "onbeforeonload", "onbeforeprint", "onblur", "oncanplay"
468 , "oncanplaythrough", "onchange", "oncontextmenu", "onclick"
469 , "ondblclick", "ondrag", "ondragend", "ondragenter", "ondragleave"
470 , "ondragover", "ondragstart", "ondrop", "ondurationchange", "onemptied"
471 , "onended", "onerror", "onfocus", "onformchange", "onforminput"
472 , "onhaschange", "oninput", "oninvalid", "onkeydown", "onkeyup"
473 , "onload", "onloadeddata", "onloadedmetadata", "onloadstart"
474 , "onmessage", "onmousedown", "onmousemove", "onmouseout", "onmouseover"
475 , "onmouseup", "onmousewheel", "ononline", "onpagehide", "onpageshow"
476 , "onpause", "onplay", "onplaying", "onprogress", "onpropstate"
477 , "onratechange", "onreadystatechange", "onredo", "onresize", "onscroll"
478 , "onseeked", "onseeking", "onselect", "onstalled", "onstorage"
479 , "onsubmit", "onsuspend", "ontimeupdate", "onundo", "onunload"
480 , "onvolumechange", "onwaiting", "open", "optimum", "pattern", "ping"
481 , "placeholder", "preload", "pubdate", "radiogroup", "readonly", "rel"
482 , "required", "reversed", "rows", "rowspan", "sandbox", "scope"
483 , "scoped", "seamless", "selected", "shape", "size", "sizes", "span"
484 , "spellcheck", "src", "srcdoc", "start", "step", "style", "subject"
485 , "summary", "tabindex", "target", "title", "type", "usemap", "value"
486 , "width", "wrap", "xmlns"
487 ]
488 , selfClosing = False
489 }
490
491-- | XHTML 5.0
492--
493xhtml5 :: HtmlVariant
494xhtml5 = HtmlVariant
495 { version = ["XHtml5"]
496 , docType = ["<!DOCTYPE HTML>"]
497 , parents = parents html5
498 , leafs = leafs html5
499 , attributes = attributes html5
500 , selfClosing = True
501 }
502
503
504-- | A map of HTML variants, per version, lowercase.
505--
506htmlVariants :: Map String HtmlVariant
507htmlVariants = M.fromList $ map (show &&& id)
508 [ html4Strict
509 , html4Transitional
510 , html4FrameSet
511 , xhtml1Strict
512 , xhtml1Transitional
513 , xhtml1FrameSet
514 , html5
515 , xhtml5
516 ]
517
518main :: IO ()
519main = mapM_ (writeHtmlVariant . snd) $ M.toList htmlVariants
diff --git a/src/Util/GenerateHtmlTCombinators.hs b/src/Util/GenerateHtmlTCombinators.hs
new file mode 100755
index 0000000..0dd5444
--- /dev/null
+++ b/src/Util/GenerateHtmlTCombinators.hs
@@ -0,0 +1,62 @@
1{-# LANGUAGE CPP #-}
2
3module Util.GenerateHtmlTCombinators where
4
5import Control.Applicative
6import Data.List
7import Language.Haskell.TH
8import System.Directory
9import System.FilePath
10import Text.Printf
11import Text.Regex
12import Text.Regex.TDFA
13import Util.GenerateHtmlCombinators hiding (getModuleName, main)
14
15declare :: HtmlVariant -> [Dec]
16declare x = concatMap (\(w,ls) -> concatMap (g w) ls)
17 [(("wrapMarkup2","Markup2"),"docTypeHtml" : parents x)
18 ,(("wrapMarkup","Markup"), "docType" : leafs x)]
19 where g (w',t') l' =
20 [SigD l $ ConT t
21 ,ValD (VarP l) (NormalB (AppE (VarE w)
22 $ VarE $ mkName $ getModuleName "Blaze" x ++"."++l')) []]
23 where [w,t,l] = fmap mkName [w',t',l']
24
25
26
27writeSource :: HtmlVariant -> IO ()
28writeSource v = mapM_ g [True, False]
29 where
30 g attr = do
31 let path = if attr then "Attributes" else ""
32 name = (if attr then "." else "") ++ path
33 [mT,m] = ((++ name) . flip getModuleName v) <$>
34 ["BlazeT","Blaze"]
35 exports = if attr then [m] else [mT, "Text.BlazeT.Html"]
36 f = (joinPath $ ["src","Text","BlazeT"] ++ version v
37 ++ [path]) <.> "hs"
38 body = if attr then "" else unlines $
39 map (printf "import Text.BlazeT%s") ["", ".Html", ".Internal"]
40 ++ ["", show ( ppr_list $ declare v)]
41 quali = if attr then "" else "qualified "
42 docs True = "This module simply reexports the corresponding @blaze-html@ module."
43 docs False = printf "This module wraps all exports of \"%s\" using 'wrapMarkup' and 'wrapMarkup'." m
44 createDirectoryIfMissing True $ takeDirectory $ f
45 writeFile f $ unlines $
46 ["-- !! DO NOT EDIT"
47 ,"{-|"
48 ,printf "(Automatically generated by @%s:%d@)\n"
49 (subRegex (mkRegex "/") __FILE__ "\\\\/") ( __LINE__ :: Int)
50 ,docs attr
51 ,"-}"
52 ,"module "++ mT
53 ," (" ++ intercalate "\n ," (map ("module "++) exports)
54 ," ) where"
55 ,"import "++ quali ++ m
56 , body]
57
58main = mapM_ writeSource htmlVariants
59
60
61getModuleName :: String -> HtmlVariant -> String
62getModuleName base = (("Text."++base++".")++) . intercalate "." . version
diff --git a/src/Util/Sanitize.hs b/src/Util/Sanitize.hs
new file mode 100644
index 0000000..112bae1
--- /dev/null
+++ b/src/Util/Sanitize.hs
@@ -0,0 +1,112 @@
1-- taken from https://github.com/jaspervdj/blaze-html/blob/2c4513e30ce768517b8d7b7b154d438f55217006/src/Util/Sanitize.hs
2
3-- Copyright Jasper Van der Jeugt 2010
4
5-- All rights reserved.
6
7-- Redistribution and use in source and binary forms, with or without
8-- modification, are permitted provided that the following conditions are met:
9
10-- * Redistributions of source code must retain the above copyright
11-- notice, this list of conditions and the following disclaimer.
12
13-- * Redistributions in binary form must reproduce the above
14-- copyright notice, this list of conditions and the following
15-- disclaimer in the documentation and/or other materials provided
16-- with the distribution.
17
18-- * Neither the name of Jasper Van der Jeugt nor the names of other
19-- contributors may be used to endorse or promote products derived
20-- from this software without specific prior written permission.
21
22-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
25-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
26-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
27-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
28-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
29-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
30-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
31-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
32-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33-- | A program to sanitize an HTML tag to a Haskell function.
34--
35module Util.Sanitize
36 ( sanitize
37 , keywords
38 , prelude
39 ) where
40
41import Data.Char (toLower, toUpper)
42import Data.Set (Set)
43import qualified Data.Set as S
44
45-- | Sanitize a tag. This function returns a name that can be used as
46-- combinator in haskell source code.
47--
48-- Examples:
49--
50-- > sanitize "class" == "class_"
51-- > sanitize "http-equiv" == "httpEquiv"
52--
53sanitize :: String -> String
54sanitize str
55 | lower == "doctypehtml" = "docTypeHtml"
56 | otherwise = appendUnderscore $ removeDash lower
57 where
58 lower = map toLower str
59
60 -- Remove a dash, replacing it by camelcase notation
61 --
62 -- Example:
63 --
64 -- > removeDash "foo-bar" == "fooBar"
65 --
66 removeDash ('-' : x : xs) = toUpper x : removeDash xs
67 removeDash (x : xs) = x : removeDash xs
68 removeDash [] = []
69
70 appendUnderscore t | t `S.member` keywords = t ++ "_"
71 | otherwise = t
72
73-- | A set of standard Haskell keywords, which cannot be used as combinators.
74--
75keywords :: Set String
76keywords = S.fromList
77 [ "case", "class", "data", "default", "deriving", "do", "else", "if"
78 , "import", "in", "infix", "infixl", "infixr", "instance" , "let", "module"
79 , "newtype", "of", "then", "type", "where"
80 ]
81
82-- | Set of functions from the Prelude, which we do not use as combinators.
83--
84prelude :: Set String
85prelude = S.fromList
86 [ "abs", "acos", "acosh", "all", "and", "any", "appendFile", "asTypeOf"
87 , "asin", "asinh", "atan", "atan2", "atanh", "break", "catch", "ceiling"
88 , "compare", "concat", "concatMap", "const", "cos", "cosh", "curry", "cycle"
89 , "decodeFloat", "div", "divMod", "drop", "dropWhile", "either", "elem"
90 , "encodeFloat", "enumFrom", "enumFromThen", "enumFromThenTo", "enumFromTo"
91 , "error", "even", "exp", "exponent", "fail", "filter", "flip"
92 , "floatDigits", "floatRadix", "floatRange", "floor", "fmap", "foldl"
93 , "foldl1", "foldr", "foldr1", "fromEnum", "fromInteger", "fromIntegral"
94 , "fromRational", "fst", "gcd", "getChar", "getContents", "getLine", "head"
95 , "id", "init", "interact", "ioError", "isDenormalized", "isIEEE"
96 , "isInfinite", "isNaN", "isNegativeZero", "iterate", "last", "lcm"
97 , "length", "lex", "lines", "log", "logBase", "lookup", "map", "mapM"
98 , "mapM_", "max", "maxBound", "maximum", "maybe", "min", "minBound"
99 , "minimum", "mod", "negate", "not", "notElem", "null", "odd", "or"
100 , "otherwise", "pi", "pred", "print", "product", "properFraction", "putChar"
101 , "putStr", "putStrLn", "quot", "quotRem", "read", "readFile", "readIO"
102 , "readList", "readLn", "readParen", "reads", "readsPrec", "realToFrac"
103 , "recip", "rem", "repeat", "replicate", "return", "reverse", "round"
104 , "scaleFloat", "scanl", "scanl1", "scanr", "scanr1", "seq", "sequence"
105 , "sequence_", "show", "showChar", "showList", "showParen", "showString"
106 , "shows", "showsPrec", "significand", "signum", "sin", "sinh", "snd"
107 , "span", "splitAt", "sqrt", "subtract", "succ", "sum", "tail", "take"
108 , "takeWhile", "tan", "tanh", "toEnum", "toInteger", "toRational"
109 , "truncate", "uncurry", "undefined", "unlines", "until", "unwords", "unzip"
110 , "unzip3", "userError", "words", "writeFile", "zip", "zip3", "zipWith"
111 , "zipWith3"
112 ]