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