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 qualified Util.GenerateHtmlCombinators.Html5 as Html5
import Util.Sanitize (sanitize, prelude)

-- | Datatype for an HTML variant.
--
data HtmlVariant = HtmlVariant
    { version     :: [String]
    , docType     :: [String]
    , parents     :: [String]
    , leafs       :: [String]
    , attributes  :: [String]
    , selfClosing :: 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 $ selfClosing 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.Html"
                               : "docType"
                               : "docTypeHtml"
                               : map (sanitize . fst) sortedTags
        , DO_NOT_EDIT
        , "import Prelude ((>>), (.))"
        , ""
        , "import Text.Blaze"
        , "import Text.Blaze.Internal"
        , "import Text.Blaze.Html"
        , ""
        , 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  = "src" </> "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 $ toHtml \"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 $ toHtml \"foo\""
    , "--"
    , "-- Result:"
    , "--"
    , "-- > <" ++ tag ++ "><span>foo</span></" ++ tag ++ ">"
    , "--"
    , function        ++ " :: Html  -- ^ Inner HTML."
    , spaces function ++ " -> Html  -- ^ Resulting HTML."
    , function        ++ " = Parent \"" ++ tag ++ "\" \"<" ++ 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    -- ^ Make leaf tags self-closing
         -> String  -- ^ Tag for the combinator
         -> String  -- ^ Combinator code
makeLeaf closing tag = unlines
    [ DO_NOT_EDIT
    , "-- | Combinator for the @\\<" ++ tag ++ " />@ element."
    , "--"
    , "-- Example:"
    , "--"
    , "-- > " ++ function
    , "--"
    , "-- Result:"
    , "--"
    , "-- > <" ++ tag ++ " />"
    , "--"
    , function ++ " :: Html  -- ^ Resulting HTML."
    , function ++ " = Leaf \"" ++ tag ++ "\" \"<" ++ tag ++ "\" " ++ "\""
               ++ (if closing then " /" else "") ++ ">\" ()"
    , "{-# INLINE " ++ function ++ " #-}"
    ]
  where
    function = sanitize tag

-- | 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 ++ "\" \" "
                      ++ 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"
        ]
    , selfClosing = False
    }

-- | 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"
        ]
    , selfClosing = False
    }

-- | 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"
        ]
    , selfClosing = False
    }

-- | XHTML 1.0 Strict
--
xhtml1Strict :: HtmlVariant
xhtml1Strict = HtmlVariant
    { version = ["XHtml1", "Strict"]
    , docType =
        [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\""
        , "    \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
        ]
    , parents = parents html4Strict
    , leafs = leafs html4Strict
    , attributes = attributes html4Strict
    , selfClosing = True
    }

-- | XHTML 1.0 Transitional
--
xhtml1Transitional :: HtmlVariant
xhtml1Transitional = HtmlVariant
    { version = ["XHtml1", "Transitional"]
    , docType =
        [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\""
        , "    \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"
        ]
    , parents = parents html4Transitional
    , leafs = leafs html4Transitional
    , attributes = attributes html4Transitional
    , selfClosing = True
    }

-- | XHTML 1.0 FrameSet
--
xhtml1FrameSet :: HtmlVariant
xhtml1FrameSet = HtmlVariant
    { version = ["XHtml1", "FrameSet"]
    , docType =
        [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 FrameSet//EN\""
        , "    \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
        ]
    , parents = parents html4FrameSet
    , leafs = leafs html4FrameSet
    , attributes = attributes html4FrameSet
    , selfClosing = True
    }

-- | HTML 5.0
-- Specified in a different file since this is the only one that is "alive".
--
html5 :: HtmlVariant
html5 = HtmlVariant
    { version     = ["Html5"]
    , docType     = ["<!DOCTYPE HTML>"]
    , parents     = Html5.parents
    , leafs       = Html5.leafs
    , attributes  = Html5.attributes
    , selfClosing = False
    }

-- | XHTML 5.0
--
xhtml5 :: HtmlVariant
xhtml5 = HtmlVariant
    { version = ["XHtml5"]
    , docType = ["<!DOCTYPE html>"]
    , parents = parents html5
    , leafs = leafs html5
    , attributes = attributes html5
    , selfClosing = True
    }


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

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