blaze-from-html-0.3.0.0: Util/GenerateHtmlCombinators.hs

{-# LANGUAGE CPP #-}

#define DO_NOT_EDIT (doNotEdit __FILE__ __LINE__)

-- | Generates code for HTML tags.
--
module Util.GenerateHtmlCombinators where

import Control.Arrow ((&&&))
import Data.List (sort, sortBy, intersperse, intercalate)
import Data.Ord (comparing)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>), (<.>))
import Data.Map (Map)
import qualified Data.Map as M
import Data.Char (toLower)
import qualified Data.Set as S

import Util.Sanitize (sanitize, prelude)

-- | Datatype for an HTML variant.
--
data HtmlVariant = HtmlVariant
    { version    :: [String]
    , docType    :: [String]
    , parents    :: [String]
    , leafs      :: [String]
    , attributes :: [String]
    , openLeafs  :: Bool
    } deriving (Eq)

instance Show HtmlVariant where
    show = map toLower . intercalate "-" . version

-- | Get the full module name for an HTML variant.
--
getModuleName :: HtmlVariant -> String
getModuleName = ("Text.Blaze." ++) . intercalate "." . version

-- | Get the attribute module name for an HTML variant.
--
getAttributeModuleName :: HtmlVariant -> String
getAttributeModuleName = (++ ".Attributes") . getModuleName

-- | Check if a given name causes a name clash.
--
isNameClash :: HtmlVariant -> String -> Bool
isNameClash v t
    -- Both an element and an attribute
    | (t `elem` parents v || t `elem` leafs v) && t `elem` attributes v = True
    -- Already a prelude function
    | sanitize t `S.member` prelude = True
    | otherwise = False

-- | Write an HTML variant.
--
writeHtmlVariant :: HtmlVariant -> IO ()
writeHtmlVariant htmlVariant = do
    -- Make a directory.
    createDirectoryIfMissing True basePath

    let tags =  zip parents' (repeat makeParent)
             ++ zip leafs' (repeat $ makeLeaf $ openLeafs htmlVariant)
        sortedTags = sortBy (comparing fst) tags
        appliedTags = map (\(x, f) -> f x) sortedTags

    -- Write the main module.
    writeFile' (basePath <.> "hs") $ removeTrailingNewlines $ unlines
        [ DO_NOT_EDIT
        , "{-# LANGUAGE OverloadedStrings #-}"
        , "-- | This module exports HTML combinators used to create documents."
        , "--"
        , exportList modulName $ "module Text.Blaze"
                                : "docType"
                                : "docTypeHtml"
                                : map (sanitize . fst) sortedTags
        , DO_NOT_EDIT
        , "import Prelude ((>>), (.))"
        , ""
        , "import Text.Blaze"
        , "import Text.Blaze.Internal"
        , ""
        , makeDocType $ docType htmlVariant
        , makeDocTypeHtml $ docType htmlVariant
        , unlines appliedTags
        ]

    let sortedAttributes = sort attributes'

    -- Write the attribute module.
    writeFile' (basePath </> "Attributes.hs") $ removeTrailingNewlines $ unlines
        [ DO_NOT_EDIT
        , "-- | This module exports combinators that provide you with the"
        , "-- ability to set attributes on HTML elements."
        , "--"
        , "{-# LANGUAGE OverloadedStrings #-}"
        , exportList attributeModuleName $ map sanitize sortedAttributes
        , DO_NOT_EDIT
        , "import Prelude ()"
        , ""
        , "import Text.Blaze.Internal (Attribute, AttributeValue, attribute)"
        , ""
        , unlines (map makeAttribute sortedAttributes)
        ]
  where
    basePath = "Text" </> "Blaze" </> foldl1 (</>) version'
    modulName = getModuleName htmlVariant
    attributeModuleName = getAttributeModuleName htmlVariant
    attributes' = attributes htmlVariant
    parents'    = parents htmlVariant
    leafs'      = leafs htmlVariant
    version'    = version htmlVariant
    removeTrailingNewlines = reverse . drop 2 . reverse
    writeFile' file content = do
        putStrLn ("Generating " ++ file)
        writeFile file content

-- | Create a string, consisting of @x@ spaces, where @x@ is the length of the
-- argument.
--
spaces :: String -> String
spaces = flip replicate ' ' . length

-- | Join blocks of code with a newline in between.
--
unblocks :: [String] -> String
unblocks = unlines . intersperse "\n"

-- | A warning to not edit the generated code.
--
doNotEdit :: FilePath -> Int -> String
doNotEdit fileName lineNumber = init $ unlines
    [ "-- WARNING: The next block of code was automatically generated by"
    , "-- " ++ fileName ++ ":" ++ show lineNumber
    , "--"
    ]

-- | Generate an export list for a Haskell module.
--
exportList :: String   -- ^ Module name.
           -> [String] -- ^ List of functions.
           -> String   -- ^ Resulting string.
exportList _    []            = error "exportList without functions."
exportList name (f:functions) = unlines $
    [ "module " ++ name
    , "    ( " ++ f
    ] ++
    map ("    , " ++) functions ++
    [ "    ) where"]

-- | Generate a function for a doctype.
--
makeDocType :: [String] -> String
makeDocType lines' = unlines
    [ DO_NOT_EDIT
    , "-- | Combinator for the document type. This should be placed at the top"
    , "-- of every HTML page."
    , "--"
    , "-- Example:"
    , "--"
    , "-- > docType"
    , "--"
    , "-- Result:"
    , "--"
    , unlines (map ("-- > " ++) lines') ++ "--"
    , "docType :: Html  -- ^ The document type HTML."
    , "docType = preEscapedText " ++ show (unlines lines')
    , "{-# INLINE docType #-}"
    ]

-- | Generate a function for the HTML tag (including the doctype).
--
makeDocTypeHtml :: [String]  -- ^ The doctype.
                -> String    -- ^ Resulting combinator function.
makeDocTypeHtml lines' = unlines
    [ DO_NOT_EDIT
    , "-- | Combinator for the @\\<html>@ element. This combinator will also"
    , "-- insert the correct doctype."
    , "--"
    , "-- Example:"
    , "--"
    , "-- > docTypeHtml $ span $ text \"foo\""
    , "--"
    , "-- Result:"
    , "--"
    , unlines (map ("-- > " ++) lines') ++ "-- > <html><span>foo</span></html>"
    , "--"
    , "docTypeHtml :: Html  -- ^ Inner HTML."
    , "            -> Html  -- ^ Resulting HTML."
    , "docTypeHtml inner = docType >> html inner"
    , "{-# INLINE docTypeHtml #-}"
    ]

-- | Generate a function for an HTML tag that can be a parent.
--
makeParent :: String -> String
makeParent tag = unlines
    [ DO_NOT_EDIT
    , "-- | Combinator for the @\\<" ++ tag ++ ">@ element."
    , "--"
    , "-- Example:"
    , "--"
    , "-- > " ++ function ++ " $ span $ text \"foo\""
    , "--"
    , "-- Result:"
    , "--"
    , "-- > <" ++ tag ++ "><span>foo</span></" ++ tag ++ ">"
    , "--"
    , function        ++ " :: Html  -- ^ Inner HTML."
    , spaces function ++ " -> Html  -- ^ Resulting HTML."
    , function        ++ " = Parent \"<" ++ tag
                      ++ "\" \"</" ++ tag ++ ">\"" ++ modifier
    , "{-# INLINE " ++ function ++ " #-}"
    ]
  where
    function = sanitize tag
    modifier = if tag `elem` ["style", "script"] then " . external" else ""

-- | Generate a function for an HTML tag that must be a leaf.
--
makeLeaf :: Bool    -- ^ If we should use open leafs
         -> String  -- ^ Tag for the combinator
         -> String  -- ^ Combinator code
makeLeaf openLeaf tag = unlines
    [ DO_NOT_EDIT
    , "-- | Combinator for the @\\<" ++ tag ++ " />@ element."
    , "--"
    , "-- Example:"
    , "--"
    , "-- > " ++ function
    , "--"
    , "-- Result:"
    , "--"
    , "-- > <" ++ tag ++ " />"
    , "--"
    , function ++ " :: Html  -- ^ Resulting HTML."
    , function ++ " = Leaf \"<" ++ tag ++ "\" " ++ end
    , "{-# INLINE " ++ function ++ " #-}"
    ]
  where
    function = sanitize tag
    end = if openLeaf then "\">\"" else "\" />\""

-- | Generate a function for an HTML attribute.
--
makeAttribute :: String -> String
makeAttribute name = unlines
    [ DO_NOT_EDIT
    , "-- | Combinator for the @" ++ name ++ "@ attribute."
    , "--"
    , "-- Example:"
    , "--"
    , "-- > div ! " ++ function ++ " \"bar\" $ \"Hello.\""
    , "--"
    , "-- Result:"
    , "--"
    , "-- > <div " ++ name ++ "=\"bar\">Hello.</div>"
    , "--"
    , function        ++ " :: AttributeValue  -- ^ Attribute value."
    , spaces function ++ " -> Attribute       -- ^ Resulting attribute."
    , function        ++ " = attribute \" " ++ name ++ "=\\\"\""
    , "{-# INLINE " ++ function ++ " #-}"
    ]
  where
    function = sanitize name

-- | HTML 4.01 Strict.
-- A good reference can be found here: http://www.w3schools.com/tags/default.asp
--
html4Strict :: HtmlVariant
html4Strict = HtmlVariant
    { version = ["Html4", "Strict"]
    , docType =
        [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\""
        , "    \"http://www.w3.org/TR/html4/strict.dtd\">"
        ]
    , parents =
        [ "a", "abbr", "acronym", "address", "b", "bdo", "big", "blockquote"
        , "body" , "button", "caption", "cite", "code", "colgroup", "dd", "del"
        , "dfn", "div" , "dl", "dt", "em", "fieldset", "form", "h1", "h2", "h3"
        , "h4", "h5", "h6", "head", "html", "i", "ins" , "kbd", "label"
        , "legend", "li", "map", "noscript", "object", "ol", "optgroup"
        , "option", "p", "pre", "q", "samp", "script", "select", "small"
        , "span", "strong", "style", "sub", "sup", "table", "tbody", "td"
        , "textarea", "tfoot", "th", "thead", "title", "tr", "tt", "ul", "var"
        ]
    , leafs =
        [ "area", "br", "col", "hr", "link", "img", "input",  "meta", "param"
        ]
    , attributes =
        [ "abbr", "accept", "accesskey", "action", "align", "alt", "archive"
        , "axis", "border", "cellpadding", "cellspacing", "char", "charoff"
        , "charset", "checked", "cite", "class", "classid", "codebase"
        , "codetype", "cols", "colspan", "content", "coords", "data", "datetime"
        , "declare", "defer", "dir", "disabled", "enctype", "for", "frame"
        , "headers", "height", "href", "hreflang", "http-equiv", "id", "label"
        , "lang", "maxlength", "media", "method", "multiple", "name", "nohref"
        , "onabort", "onblur", "onchange", "onclick", "ondblclick", "onfocus"
        , "onkeydown", "onkeypress", "onkeyup", "onload", "onmousedown"
        , "onmousemove", "onmouseout", "onmouseover", "onmouseup", "onreset"
        , "onselect", "onsubmit", "onunload", "profile", "readonly", "rel"
        , "rev", "rows", "rowspan", "rules", "scheme", "scope", "selected"
        , "shape", "size", "span", "src", "standby", "style", "summary"
        , "tabindex", "title", "type", "usemap", "valign", "value", "valuetype"
        , "width"
        ]
    , openLeafs = True
    }

-- | HTML 4.0 Transitional
--
html4Transitional :: HtmlVariant
html4Transitional = HtmlVariant
    { version = ["Html4", "Transitional"]
    , docType =
        [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\""
        , "    \"http://www.w3.org/TR/html4/loose.dtd\">"
        ]
    , parents = parents html4Strict ++
        [ "applet", "center", "dir", "font", "iframe", "isindex", "menu"
        , "noframes", "s", "u"
        ]
    , leafs = leafs html4Strict ++ ["basefont"]
    , attributes = attributes html4Strict ++
        [ "background", "bgcolor", "clear", "compact", "hspace", "language"
        , "noshade", "nowrap", "start", "target", "vspace"
        ]
    , openLeafs = True
    }

-- | HTML 4.0 Frameset
--
html4FrameSet :: HtmlVariant
html4FrameSet = HtmlVariant
    { version = ["Html4", "FrameSet"]
    , docType =
        [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\""
        , "    \"http://www.w3.org/TR/html4/frameset.dtd\">"
        ]
    , parents = parents html4Transitional ++ ["frameset"]
    , leafs = leafs html4Transitional ++ ["frame"]
    , attributes = attributes html4Transitional ++
        [ "frameborder", "scrolling"
        ]
    , openLeafs = True
    }

-- | HTML 5.0
-- A good reference can be found here:
-- http://www.w3schools.com/html5/html5_reference.asp
--
html5 :: HtmlVariant
html5 = HtmlVariant
    { version = ["Html5"]
    , docType = ["<!DOCTYPE HTML>"]
    , parents =
        [ "a", "abbr", "address", "article", "aside", "audio", "b", "base"
        , "bdo", "blockquote", "body", "button", "canvas", "caption", "cite"
        , "code", "colgroup", "command", "datalist", "dd", "del", "details"
        , "dfn", "div", "dl", "dt", "em", "fieldset", "figcaption", "figure"
        , "footer", "form", "h1", "h2", "h3", "h4", "h5", "h6", "head", "header"
        , "hgroup", "html", "i", "iframe", "ins", "keygen", "kbd", "label"
        , "legend", "li", "map", "mark", "menu", "meter", "nav", "noscript"
        , "object", "ol", "optgroup", "option", "output", "p", "pre", "progress"
        , "q", "rp", "rt", "ruby", "samp", "script", "section", "select"
        , "small", "source", "span", "strong", "style", "sub", "summary", "sup"
        , "table", "tbody", "td", "textarea", "tfoot", "th", "thead", "time"
        , "title", "tr", "ul", "var", "video"
        ]
    , leafs =
        [ "area", "br", "col", "embed", "hr", "img", "input", "meta", "link"
        , "param"
        ]
    , attributes =
        [ "accept", "accept-charset", "accesskey", "action", "alt", "async"
        , "autocomplete", "autofocus", "autoplay", "challenge", "charset"
        , "checked", "cite", "class", "cols", "colspan", "content"
        , "contenteditable", "contextmenu", "controls", "coords", "data"
        , "datetime", "defer", "dir", "disabled", "draggable", "enctype", "for"
        , "form", "formaction", "formenctype", "formmethod", "formnovalidate"
        , "formtarget", "headers", "height", "hidden", "high", "href"
        , "hreflang", "http-equiv", "icon", "id", "ismap", "item", "itemprop"
        , "keytype", "label", "lang", "list", "loop", "low", "manifest", "max"
        , "maxlength", "media", "method", "min", "multiple", "name"
        , "novalidate", "onbeforeonload", "onbeforeprint", "oncanplay"
        , "oncanplaythrough", "onchange", "oncontextmenu", "onclick"
        , "ondblclick", "ondrag", "ondragend", "ondragenter", "ondragleave"
        , "ondragover", "ondragstart", "ondrop", "ondurationchange", "onemptied"
        , "onended", "onerror", "onfocus", "onformchange", "onforminput"
        , "onhaschange", "oninput", "oninvalid", "onkeydown", "onkeyup"
        , "onload", "onloadeddata", "onloadedmetadata", "onloadstart"
        , "onmessage", "onmousedown", "onmousemove", "onmouseout", "onmouseover"
        , "onmouseup", "onmousewheel", "ononline", "onpagehide", "onpageshow"
        , "onpause", "onplay", "onplaying", "onprogress", "onpropstate"
        , "onratechange", "onreadystatechange", "onredo", "onresize", "onscroll"
        , "onseeked", "onseeking", "onselect", "onstalled", "onstorage"
        , "onsubmit", "onsuspend", "ontimeupdate", "onundo", "onunload"
        , "onvolumechange", "onwaiting", "open", "optimum", "pattern", "ping"
        , "placeholder", "preload", "pubdate", "radiogroup", "readonly", "rel"
        , "required", "reversed", "rows", "rowspan", "sandbox", "scope"
        , "scoped", "seamless", "selected", "shape", "size", "sizes", "span"
        , "spellcheck", "src", "srcdoc", "start", "step", "style", "subject"
        , "summary", "tabindex", "target", "title", "type", "usemap", "value"
        , "width", "wrap", "xmlns"
        ]
    , openLeafs = False
    }

-- | A map of HTML variants, per version, lowercase.
--
htmlVariants :: Map String HtmlVariant
htmlVariants = M.fromList $ map (show &&& id)
    [ html4Strict
    , html4Transitional
    , html4FrameSet
    , html5
    ]

main :: IO ()
main = mapM_ (writeHtmlVariant . snd) $ M.toList htmlVariants