1{-# LANGUAGE CPP #-}
2
3#define DO_NOT_EDIT (doNotEdit __FILE__ __LINE__)
4
5-- | Generates code for HTML tags.
6--
7module Util.GenerateHtmlCombinators where
8
9import Control.Arrow ((&&&))
10import Data.List (sort, sortBy, intersperse, intercalate)
11import Data.Ord (comparing)
12import System.Directory (createDirectoryIfMissing)
13import System.FilePath ((</>), (<.>))
14import Data.Map (Map)
15import qualified Data.Map as M
16import Data.Char (toLower)
17import qualified Data.Set as S
18
19import Util.Sanitize (sanitize, prelude)
20
21-- | Datatype for an HTML variant.
22--
23data HtmlVariant = HtmlVariant
24    { version     :: [String]
25    , docType     :: [String]
26    , parents     :: [String]
27    , leafs       :: [String]
28    , attributes  :: [String]
29    , selfClosing :: Bool
30    } deriving (Eq)
31
32instance Show HtmlVariant where
33    show = map toLower . intercalate "-" . version
34
35-- | Get the full module name for an HTML variant.
36--
37getModuleName :: HtmlVariant -> String
38getModuleName = ("Text.Blaze." ++) . intercalate "." . version
39
40-- | Get the attribute module name for an HTML variant.
41--
42getAttributeModuleName :: HtmlVariant -> String
43getAttributeModuleName = (++ ".Attributes") . getModuleName
44
45-- | Check if a given name causes a name clash.
46--
47isNameClash :: HtmlVariant -> String -> Bool
48isNameClash v t
49    -- Both an element and an attribute
50    | (t `elem` parents v || t `elem` leafs v) && t `elem` attributes v = True
51    -- Already a prelude function
52    | sanitize t `S.member` prelude = True
53    | otherwise = False
54
55-- | Write an HTML variant.
56--
57writeHtmlVariant :: HtmlVariant -> IO ()
58writeHtmlVariant htmlVariant = do
59    -- Make a directory.
60    createDirectoryIfMissing True basePath
61
62    let tags =  zip parents' (repeat makeParent)
63             ++ zip leafs' (repeat (makeLeaf $ selfClosing htmlVariant))
64        sortedTags = sortBy (comparing fst) tags
65        appliedTags = map (\(x, f) -> f x) sortedTags
66
67    -- Write the main module.
68    writeFile' (basePath <.> "hs") $ removeTrailingNewlines $ unlines
69        [ DO_NOT_EDIT
70        , "{-# LANGUAGE OverloadedStrings #-}"
71        , "-- | This module exports HTML combinators used to create documents."
72        , "--"
73        , exportList modulName $ "module Text.Blaze.Html"
74                               : "docType"
75                               : "docTypeHtml"
76                               : map (sanitize . fst) sortedTags
77        , DO_NOT_EDIT
78        , "import Prelude ((>>), (.))"
79        , ""
80        , "import Text.Blaze"
81        , "import Text.Blaze.Internal"
82        , "import Text.Blaze.Html"
83        , ""
84        , makeDocType $ docType htmlVariant
85        , makeDocTypeHtml $ docType htmlVariant
86        , unlines appliedTags
87        ]
88
89    let sortedAttributes = sort attributes'
90
91    -- Write the attribute module.
92    writeFile' (basePath </> "Attributes.hs") $ removeTrailingNewlines $ unlines
93        [ DO_NOT_EDIT
94        , "-- | This module exports combinators that provide you with the"
95        , "-- ability to set attributes on HTML elements."
96        , "--"
97        , "{-# LANGUAGE OverloadedStrings #-}"
98        , exportList attributeModuleName $ map sanitize sortedAttributes
99        , DO_NOT_EDIT
100        , "import Prelude ()"
101        , ""
102        , "import Text.Blaze.Internal (Attribute, AttributeValue, attribute)"
103        , ""
104        , unlines (map makeAttribute sortedAttributes)
105        ]
106  where
107    basePath  = "src" </> "Text" </> "Blaze" </> foldl1 (</>) version'
108    modulName = getModuleName htmlVariant
109    attributeModuleName = getAttributeModuleName htmlVariant
110    attributes' = attributes htmlVariant
111    parents'    = parents htmlVariant
112    leafs'      = leafs htmlVariant
113    version'    = version htmlVariant
114    removeTrailingNewlines = reverse . drop 2 . reverse
115    writeFile' file content = do
116        putStrLn ("Generating " ++ file)
117        writeFile file content
118
119-- | Create a string, consisting of @x@ spaces, where @x@ is the length of the
120-- argument.
121--
122spaces :: String -> String
123spaces = flip replicate ' ' . length
124
125-- | Join blocks of code with a newline in between.
126--
127unblocks :: [String] -> String
128unblocks = unlines . intersperse "\n"
129
130-- | A warning to not edit the generated code.
131--
132doNotEdit :: FilePath -> Int -> String
133doNotEdit fileName lineNumber = init $ unlines
134    [ "-- WARNING: The next block of code was automatically generated by"
135    , "-- " ++ fileName ++ ":" ++ show lineNumber
136    , "--"
137    ]
138
139-- | Generate an export list for a Haskell module.
140--
141exportList :: String   -- ^ Module name.
142           -> [String] -- ^ List of functions.
143           -> String   -- ^ Resulting string.
144exportList _    []            = error "exportList without functions."
145exportList name (f:functions) = unlines $
146    [ "module " ++ name
147    , "    ( " ++ f
148    ] ++
149    map ("    , " ++) functions ++
150    [ "    ) where"]
151
152-- | Generate a function for a doctype.
153--
154makeDocType :: [String] -> String
155makeDocType lines' = unlines
156    [ DO_NOT_EDIT
157    , "-- | Combinator for the document type. This should be placed at the top"
158    , "-- of every HTML page."
159    , "--"
160    , "-- Example:"
161    , "--"
162    , "-- > docType"
163    , "--"
164    , "-- Result:"
165    , "--"
166    , unlines (map ("-- > " ++) lines') ++ "--"
167    , "docType :: Html  -- ^ The document type HTML."
168    , "docType = preEscapedText " ++ show (unlines lines')
169    , "{-# INLINE docType #-}"
170    ]
171
172-- | Generate a function for the HTML tag (including the doctype).
173--
174makeDocTypeHtml :: [String]  -- ^ The doctype.
175                -> String    -- ^ Resulting combinator function.
176makeDocTypeHtml lines' = unlines
177    [ DO_NOT_EDIT
178    , "-- | Combinator for the @\\<html>@ element. This combinator will also"
179    , "-- insert the correct doctype."
180    , "--"
181    , "-- Example:"
182    , "--"
183    , "-- > docTypeHtml $ span $ toHtml \"foo\""
184    , "--"
185    , "-- Result:"
186    , "--"
187    , unlines (map ("-- > " ++) lines') ++ "-- > <html><span>foo</span></html>"
188    , "--"
189    , "docTypeHtml :: Html  -- ^ Inner HTML."
190    , "            -> Html  -- ^ Resulting HTML."
191    , "docTypeHtml inner = docType >> html inner"
192    , "{-# INLINE docTypeHtml #-}"
193    ]
194
195-- | Generate a function for an HTML tag that can be a parent.
196--
197makeParent :: String -> String
198makeParent tag = unlines
199    [ DO_NOT_EDIT
200    , "-- | Combinator for the @\\<" ++ tag ++ ">@ element."
201    , "--"
202    , "-- Example:"
203    , "--"
204    , "-- > " ++ function ++ " $ span $ toHtml \"foo\""
205    , "--"
206    , "-- Result:"
207    , "--"
208    , "-- > <" ++ tag ++ "><span>foo</span></" ++ tag ++ ">"
209    , "--"
210    , function        ++ " :: Html  -- ^ Inner HTML."
211    , spaces function ++ " -> Html  -- ^ Resulting HTML."
212    , function        ++ " = Parent \"" ++ tag ++ "\" \"<" ++ tag
213                      ++ "\" \"</" ++ tag ++ ">\"" ++ modifier
214    , "{-# INLINE " ++ function ++ " #-}"
215    ]
216  where
217    function = sanitize tag
218    modifier = if tag `elem` ["style", "script"] then " . external" else ""
219
220-- | Generate a function for an HTML tag that must be a leaf.
221--
222makeLeaf :: Bool    -- ^ Make leaf tags self-closing
223         -> String  -- ^ Tag for the combinator
224         -> String  -- ^ Combinator code
225makeLeaf closing tag = unlines
226    [ DO_NOT_EDIT
227    , "-- | Combinator for the @\\<" ++ tag ++ " />@ element."
228    , "--"
229    , "-- Example:"
230    , "--"
231    , "-- > " ++ function
232    , "--"
233    , "-- Result:"
234    , "--"
235    , "-- > <" ++ tag ++ " />"
236    , "--"
237    , function ++ " :: Html  -- ^ Resulting HTML."
238    , function ++ " = Leaf \"" ++ tag ++ "\" \"<" ++ tag ++ "\" " ++ "\""
239               ++ (if closing then " /" else "") ++ ">\" ()"
240    , "{-# INLINE " ++ function ++ " #-}"
241    ]
242  where
243    function = sanitize tag
244
245-- | Generate a function for an HTML attribute.
246--
247makeAttribute :: String -> String
248makeAttribute name = unlines
249    [ DO_NOT_EDIT
250    , "-- | Combinator for the @" ++ name ++ "@ attribute."
251    , "--"
252    , "-- Example:"
253    , "--"
254    , "-- > div ! " ++ function ++ " \"bar\" $ \"Hello.\""
255    , "--"
256    , "-- Result:"
257    , "--"
258    , "-- > <div " ++ name ++ "=\"bar\">Hello.</div>"
259    , "--"
260    , function        ++ " :: AttributeValue  -- ^ Attribute value."
261    , spaces function ++ " -> Attribute       -- ^ Resulting attribute."
262    , function        ++ " = attribute \"" ++ name ++ "\" \" "
263                      ++ name ++ "=\\\"\""
264    , "{-# INLINE " ++ function ++ " #-}"
265    ]
266  where
267    function = sanitize name
268
269-- | HTML 4.01 Strict.
270-- A good reference can be found here: http://www.w3schools.com/tags/default.asp
271--
272html4Strict :: HtmlVariant
273html4Strict = HtmlVariant
274    { version = ["Html4", "Strict"]
275    , docType =
276        [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\""
277        , "    \"http://www.w3.org/TR/html4/strict.dtd\">"
278        ]
279    , parents =
280        [ "a", "abbr", "acronym", "address", "b", "bdo", "big", "blockquote"
281        , "body" , "button", "caption", "cite", "code", "colgroup", "dd", "del"
282        , "dfn", "div" , "dl", "dt", "em", "fieldset", "form", "h1", "h2", "h3"
283        , "h4", "h5", "h6", "head", "html", "i", "ins" , "kbd", "label"
284        , "legend", "li", "map", "noscript", "object", "ol", "optgroup"
285        , "option", "p", "pre", "q", "samp", "script", "select", "small"
286        , "span", "strong", "style", "sub", "sup", "table", "tbody", "td"
287        , "textarea", "tfoot", "th", "thead", "title", "tr", "tt", "ul", "var"
288        ]
289    , leafs =
290        [ "area", "br", "col", "hr", "link", "img", "input",  "meta", "param"
291        ]
292    , attributes =
293        [ "abbr", "accept", "accesskey", "action", "align", "alt", "archive"
294        , "axis", "border", "cellpadding", "cellspacing", "char", "charoff"
295        , "charset", "checked", "cite", "class", "classid", "codebase"
296        , "codetype", "cols", "colspan", "content", "coords", "data", "datetime"
297        , "declare", "defer", "dir", "disabled", "enctype", "for", "frame"
298        , "headers", "height", "href", "hreflang", "http-equiv", "id", "label"
299        , "lang", "maxlength", "media", "method", "multiple", "name", "nohref"
300        , "onabort", "onblur", "onchange", "onclick", "ondblclick", "onfocus"
301        , "onkeydown", "onkeypress", "onkeyup", "onload", "onmousedown"
302        , "onmousemove", "onmouseout", "onmouseover", "onmouseup", "onreset"
303        , "onselect", "onsubmit", "onunload", "profile", "readonly", "rel"
304        , "rev", "rows", "rowspan", "rules", "scheme", "scope", "selected"
305        , "shape", "size", "span", "src", "standby", "style", "summary"
306        , "tabindex", "title", "type", "usemap", "valign", "value", "valuetype"
307        , "width"
308        ]
309    , selfClosing = False
310    }
311
312-- | HTML 4.0 Transitional
313--
314html4Transitional :: HtmlVariant
315html4Transitional = HtmlVariant
316    { version = ["Html4", "Transitional"]
317    , docType =
318        [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\""
319        , "    \"http://www.w3.org/TR/html4/loose.dtd\">"
320        ]
321    , parents = parents html4Strict ++
322        [ "applet", "center", "dir", "font", "iframe", "isindex", "menu"
323        , "noframes", "s", "u"
324        ]
325    , leafs = leafs html4Strict ++ ["basefont"]
326    , attributes = attributes html4Strict ++
327        [ "background", "bgcolor", "clear", "compact", "hspace", "language"
328        , "noshade", "nowrap", "start", "target", "vspace"
329        ]
330    , selfClosing = False
331    }
332
333-- | HTML 4.0 FrameSet
334--
335html4FrameSet :: HtmlVariant
336html4FrameSet = HtmlVariant
337    { version = ["Html4", "FrameSet"]
338    , docType =
339        [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 FrameSet//EN\""
340        , "    \"http://www.w3.org/TR/html4/frameset.dtd\">"
341        ]
342    , parents = parents html4Transitional ++ ["frameset"]
343    , leafs = leafs html4Transitional ++ ["frame"]
344    , attributes = attributes html4Transitional ++
345        [ "frameborder", "scrolling"
346        ]
347    , selfClosing = False
348    }
349
350-- | XHTML 1.0 Strict
351--
352xhtml1Strict :: HtmlVariant
353xhtml1Strict = HtmlVariant
354    { version = ["XHtml1", "Strict"]
355    , docType =
356        [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\""
357        , "    \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
358        ]
359    , parents = parents html4Strict
360    , leafs = leafs html4Strict
361    , attributes = attributes html4Strict
362    , selfClosing = True
363    }
364
365-- | XHTML 1.0 Transitional
366--
367xhtml1Transitional :: HtmlVariant
368xhtml1Transitional = HtmlVariant
369    { version = ["XHtml1", "Transitional"]
370    , docType =
371        [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\""
372        , "    \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"
373        ]
374    , parents = parents html4Transitional
375    , leafs = leafs html4Transitional
376    , attributes = attributes html4Transitional
377    , selfClosing = True
378    }
379
380-- | XHTML 1.0 FrameSet
381--
382xhtml1FrameSet :: HtmlVariant
383xhtml1FrameSet = HtmlVariant
384    { version = ["XHtml1", "FrameSet"]
385    , docType =
386        [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 FrameSet//EN\""
387        , "    \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
388        ]
389    , parents = parents html4FrameSet
390    , leafs = leafs html4FrameSet
391    , attributes = attributes html4FrameSet
392    , selfClosing = True
393    }
394
395-- | HTML 5.0
396-- A good reference can be found here:
397-- http://www.w3schools.com/html5/html5_reference.asp
398--
399html5 :: HtmlVariant
400html5 = HtmlVariant
401    { version = ["Html5"]
402    , docType = ["<!DOCTYPE HTML>"]
403    , parents =
404        [ "a", "abbr", "address", "article", "aside", "audio", "b"
405        , "bdo", "blockquote", "body", "button", "canvas", "caption", "cite"
406        , "code", "colgroup", "command", "datalist", "dd", "del", "details"
407        , "dfn", "div", "dl", "dt", "em", "fieldset", "figcaption", "figure"
408        , "footer", "form", "h1", "h2", "h3", "h4", "h5", "h6", "head", "header"
409        , "hgroup", "html", "i", "iframe", "ins", "kbd", "label"
410        , "legend", "li", "main", "map", "mark", "menu", "meter", "nav"
411        , "noscript", "object", "ol", "optgroup", "option", "output", "p"
412        , "pre", "progress", "q", "rp", "rt", "ruby", "samp", "script"
413        , "section", "select", "small", "span", "strong", "style", "sub"
414        , "summary", "sup", "table", "tbody", "td", "textarea", "tfoot", "th"
415        , "thead", "time", "title", "tr", "u", "ul", "var", "video"
416        ]
417    , leafs =
418        -- http://www.whatwg.org/specs/web-apps/current-work/multipage/syntax.html#void-elements
419        [ "area", "base", "br", "col", "embed", "hr", "img", "input", "keygen"
420        , "link", "menuitem", "meta", "param", "source", "track", "wbr"
421        ]
422    , attributes =
423        [ "accept", "accept-charset", "accesskey", "action", "alt", "async"
424        , "autocomplete", "autofocus", "autoplay", "challenge", "charset"
425        , "checked", "cite", "class", "cols", "colspan", "content"
426        , "contenteditable", "contextmenu", "controls", "coords", "data"
427        , "datetime", "defer", "dir", "disabled", "draggable", "enctype", "for"
428        , "form", "formaction", "formenctype", "formmethod", "formnovalidate"
429        , "formtarget", "headers", "height", "hidden", "high", "href"
430        , "hreflang", "http-equiv", "icon", "id", "ismap", "item", "itemprop"
431        , "itemscope", "itemtype"
432        , "keytype", "label", "lang", "list", "loop", "low", "manifest", "max"
433        , "maxlength", "media", "method", "min", "multiple", "name"
434        , "novalidate", "onbeforeonload", "onbeforeprint", "onblur", "oncanplay"
435        , "oncanplaythrough", "onchange", "oncontextmenu", "onclick"
436        , "ondblclick", "ondrag", "ondragend", "ondragenter", "ondragleave"
437        , "ondragover", "ondragstart", "ondrop", "ondurationchange", "onemptied"
438        , "onended", "onerror", "onfocus", "onformchange", "onforminput"
439        , "onhaschange", "oninput", "oninvalid", "onkeydown", "onkeyup"
440        , "onload", "onloadeddata", "onloadedmetadata", "onloadstart"
441        , "onmessage", "onmousedown", "onmousemove", "onmouseout", "onmouseover"
442        , "onmouseup", "onmousewheel", "ononline", "onpagehide", "onpageshow"
443        , "onpause", "onplay", "onplaying", "onprogress", "onpropstate"
444        , "onratechange", "onreadystatechange", "onredo", "onresize", "onscroll"
445        , "onseeked", "onseeking", "onselect", "onstalled", "onstorage"
446        , "onsubmit", "onsuspend", "ontimeupdate", "onundo", "onunload"
447        , "onvolumechange", "onwaiting", "open", "optimum", "pattern", "ping"
448        , "placeholder", "preload", "pubdate", "radiogroup", "readonly", "rel"
449        , "required", "reversed", "role", "rows", "rowspan", "sandbox", "scope"
450        , "scoped", "seamless", "selected", "shape", "size", "sizes", "span"
451        , "spellcheck", "src", "srcdoc", "start", "step", "style", "subject"
452        , "summary", "tabindex", "target", "title", "type", "usemap", "value"
453        , "width", "wrap", "xmlns"
454        ]
455    , selfClosing = False
456    }
457
458-- | XHTML 5.0
459--
460xhtml5 :: HtmlVariant
461xhtml5 = HtmlVariant
462    { version = ["XHtml5"]
463    , docType = ["<!DOCTYPE HTML>"]
464    , parents = parents html5
465    , leafs = leafs html5
466    , attributes = attributes html5
467    , selfClosing = True
468    }
469
470
471-- | A map of HTML variants, per version, lowercase.
472--
473htmlVariants :: Map String HtmlVariant
474htmlVariants = M.fromList $ map (show &&& id)
475    [ html4Strict
476    , html4Transitional
477    , html4FrameSet
478    , xhtml1Strict
479    , xhtml1Transitional
480    , xhtml1FrameSet
481    , html5
482    , xhtml5
483    ]
484
485main :: IO ()
486main = mapM_ (writeHtmlVariant . snd) $ M.toList htmlVariants
487