packages feed

blaze-from-html 0.3.2.0 → 0.3.2.1

raw patch · 7 files changed

+881/−875 lines, 7 files

Files

− Util/BlazeFromHtml.hs 
@@ -1,327 +0,0 @@--- | A module for conversion from HTML to BlazeHtml Haskell code.----module Main where--import Control.Monad (forM_, when)-import Control.Applicative ((<$>))-import Data.List (isPrefixOf, stripPrefix)-import Data.Maybe (listToMaybe, fromMaybe, fromJust)-import Data.Char (toLower, isSpace)-import Control.Arrow (first)-import System.Environment (getArgs)-import System.FilePath (dropExtension)-import qualified Data.Map as M-import System.Console.GetOpt--import Text.HTML.TagSoup--import Util.Sanitize (sanitize)-import Util.GenerateHtmlCombinators hiding (main)---- | Simple type to represent attributes.----type Attributes = [(String, String)]---- | Intermediate tree representation. This representation contains several--- constructors aimed at pretty-printing.----data Html = Parent String Attributes Html-          | Block [Html]-          | Text String-          | Comment String-          | Doctype-          deriving (Show)---- | Different combinator types.----data CombinatorType = ParentCombinator-                    | LeafCombinator-                    | UnknownCombinator-                    deriving (Eq, Show)---- | Traverse the list of tags to produce an intermediate representation of the--- HTML tree.----makeTree :: HtmlVariant           -- ^ HTML variant used-         -> Bool                  -- ^ Should ignore errors-         -> [String]              -- ^ Stack of open tags-         -> [Tag String]          -- ^ Tags to parse-         -> (Html, [Tag String])  -- ^ (Result, unparsed part)-makeTree _ ignore stack []-    | null stack || ignore = (Block [], [])-    | otherwise = error $ "Error: tags left open at the end: " ++ show stack-makeTree variant ignore stack (TagPosition row _ : x : xs) = case x of-    TagOpen tag attrs -> if toLower' tag == "!doctype"-        then addHtml Doctype xs-        else let tag' = toLower' tag-                 (inner, t) = case combinatorType variant tag' of-                    LeafCombinator -> (Block [], xs)-                    _ -> makeTree variant ignore (tag' : stack) xs-                 p = Parent tag' (map (first toLower') attrs) inner-             in addHtml p t-    -- The closing tag must match the stack. If it is a closing leaf, we can-    -- ignore it-    TagClose tag ->-        let isLeafCombinator = combinatorType variant tag == LeafCombinator-            matchesStack = listToMaybe stack == Just (toLower' tag)-        in case (isLeafCombinator, matchesStack, ignore) of-            -- It's a leaf combinator, don't care about this element-            (True, _, _)          -> makeTree variant ignore stack xs-            -- It's a parent and the stack doesn't match-            (False, False, False) -> error $-                "Line " ++ show row ++ ": " ++ show tag ++ " closed but "-                        ++ show stack ++ " should be closed instead."-            -- Stack might not match but we ignore it anyway-            (False, _, _)         -> (Block [], xs)-    TagText text -> addHtml (Text text) xs-    TagComment comment -> addHtml (Comment comment) xs-    _ -> makeTree variant ignore stack xs-  where-    addHtml html xs' = let (Block l, r) = makeTree variant ignore stack xs'-                       in (Block (html : l), r)--    toLower' = map toLower-makeTree _ _ _ _ = error "TagSoup error"---- | Remove empty text from the HTML.----removeEmptyText :: Html -> Html-removeEmptyText (Block b) = Block $ map removeEmptyText $ flip filter b $ \h ->-    case h of Text text -> any (not . isSpace) text-              _         -> True-removeEmptyText (Parent tag attrs inner) =-    Parent tag attrs $ removeEmptyText inner-removeEmptyText x = x---- | Try to eliminiate Block constructors as much as possible.----minimizeBlocks :: Html -> Html-minimizeBlocks (Parent t a (Block [x])) = minimizeBlocks $ Parent t a x-minimizeBlocks (Parent t a x) = Parent t a $ minimizeBlocks x-minimizeBlocks (Block x) = Block $ map minimizeBlocks x-minimizeBlocks x = x---- | Get the type of a combinator, using a given variant.----combinatorType :: HtmlVariant -> String -> CombinatorType-combinatorType variant combinator-    | combinator == "docTypeHtml" = ParentCombinator-    | combinator `elem` parents variant = ParentCombinator-    | combinator `elem` leafs variant = LeafCombinator-    | otherwise = UnknownCombinator---- | Create a special @<html>@ parent that includes the docype.----joinHtmlDoctype :: Html -> Html-joinHtmlDoctype (Block (Doctype : Parent "html" attrs inner : xs)) =-    Block $ Parent "docTypeHtml" attrs inner : xs-joinHtmlDoctype x = x---- | Produce the Blaze code from the HTML. The result is a list of lines.----fromHtml :: HtmlVariant  -- ^ Used HTML variant-         -> Bool         -- ^ Should ignore errors-         -> Html         -- ^ HTML tree-         -> [String]     -- ^ Resulting lines of code-fromHtml _ _ Doctype = ["docType"]-fromHtml _ _ (Text text) = ["\"" ++ concatMap escape (trim text) ++ "\""]-  where-    -- Remove whitespace on both ends of a string-    trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace-    -- Escape a number of characters-    escape '"'  = "\\\""-    escape '\n' = "\\n"-    escape x    = [x]-fromHtml _ _ (Comment comment) = map ("-- " ++) $ lines comment-fromHtml variant ignore (Block block) =-    concatMap (fromHtml variant ignore) block-fromHtml variant ignore (Parent tag attrs inner) =-    case combinatorType variant tag of-        -- Actual parent tags-        ParentCombinator -> case inner of-            (Block ls) -> if null ls-                then [combinator ++-                        (if null attrs then " " else " $ ") ++ "mempty"]-                else (combinator ++ " $ do") :-                        indent (fromHtml variant ignore inner)-            -- We join non-block parents for better readability.-            x -> let ls = fromHtml variant ignore x-                     apply = if dropApply x then " " else " $ "-                 in case ls of (y : ys) -> (combinator ++ apply ++ y) : ys-                               [] -> [combinator]--        -- Leaf tags-        LeafCombinator -> [combinator]--        -- Unknown tag-        UnknownCombinator -> if ignore-            then fromHtml variant ignore inner-            else error $ "Tag " ++ tag ++ " is illegal in "-                                       ++ show variant-  where-    combinator = qualifiedSanitize "H." tag ++ attributes'-    attributes' = attrs >>= \(k, v) -> case k `elem` attributes variant of-        True  -> " ! " ++ qualifiedSanitize "A." k ++ " " ++ show v-        False-            | "data-" `isPrefixOf` k -> " ! "-                                     ++ "dataAttribute" ++ " "-                                     ++ show (fromJust $ stripPrefix "data-" k)-                                     ++ " " ++ show v-            | ignore                 -> ""-            | otherwise              -> error $ "Attribute "-                                     ++ k ++ " is illegal in "-                                     ++ show variant--    -- Qualifies a tag with the given qualifier if needed, and sanitizes it.-    qualifiedSanitize qualifier tag' =-        (if isNameClash variant tag' then qualifier else "") ++ sanitize tag'--    -- Check if we can drop the apply operator ($), for readability reasons.-    -- This would change:-    ---    -- > p $ "Some text"-    ---    -- Into-    ---    -- > p "Some text"-    ---    dropApply (Parent _ _ _) = False-    dropApply (Block _) = False-    dropApply _ = null attrs---- | Produce the code needed for initial imports.----getImports :: HtmlVariant -> [String]-getImports variant =-    [ "{-# LANGUAGE OverloadedStrings #-}"-    , ""-    , import_ "Prelude"-    , qualify "Prelude" "P"-    , import_ "Data.Monoid (mempty)"-    , ""-    , import_ h-    , qualify h "H"-    , import_ a-    , qualify a "A"-    ]-  where-    import_ = ("import " ++)-    qualify name short = "import qualified " ++ name ++ " as " ++ short-    h = getModuleName variant-    a = getAttributeModuleName variant---- | Convert the HTML to blaze code.----blazeFromHtml :: HtmlVariant  -- ^ Variant to use-              -> Bool         -- ^ Produce standalone code-              -> Bool         -- ^ Should we ignore errors-              -> String       -- ^ Template name-              -> String       -- ^ HTML code-              -> String       -- ^ Resulting code-blazeFromHtml variant standalone ignore name =-    unlines . addSignature . fromHtml variant ignore-            . joinHtmlDoctype . minimizeBlocks-            . removeEmptyText . fst . makeTree variant ignore []-            . parseTagsOptions parseOptions { optTagPosition = True }-  where-    addSignature body = if standalone then [ name ++ " :: Html"-                                           , name ++ " = do"-                                           ] ++ indent body-                                      else body---- | Indent block of code.----indent :: [String] -> [String]-indent = map ("    " ++)---- | Main function----main :: IO ()-main = do-    args <- getOpt Permute options <$> getArgs-    case args of-        (o, n, []) -> let v = getVariant o-                          s = standalone' o-                          i = ignore' o-                      in do imports' v o-                            main' v s i n-        (_, _, _)  -> putStr help-  where-    -- No files given, work with stdin-    main' variant standalone ignore [] = interact $-        blazeFromHtml variant standalone ignore "template"--    -- Handle all files-    main' variant standalone ignore files = forM_ files $ \file -> do-        body <- readFile file-        putStrLn $ blazeFromHtml variant standalone ignore-                                 (dropExtension file) body--    -- Print imports if needed-    imports' variant opts = when (standalone' opts) $-        putStrLn $ unlines $ getImports variant--    -- Should we produce standalone code?-    standalone' opts = ArgStandalone `elem` opts--    -- Should we ignore errors?-    ignore' opts = ArgIgnoreErrors `elem` opts--    -- Get the variant from the options-    getVariant opts = fromMaybe defaultHtmlVariant $ listToMaybe $-        flip concatMap opts $ \o -> case o of (ArgHtmlVariant x) -> [x]-                                              _ -> []---- | Help information.----help :: String-help = unlines $-    [ "This is a tool to convert HTML code to BlazeHtml code. It is still"-    , "experimental and the results might need to be edited manually."-    , ""-    , "USAGE"-    , ""-    , "  blaze-from-html [OPTIONS...] [FILES ...]"-    , ""-    , "When no files are given, it works as a filter."-    , ""-    , "EXAMPLE"-    , ""-    , "  blaze-from-html -v html4-strict index.html"-    , ""-    , "This converts the index.html file to Haskell code, writing to stdout."-    , ""-    , "OPTIONS"-    , usageInfo "" options-    , "VARIANTS"-    , ""-    ] ++-    map (("  " ++) . fst) (M.toList htmlVariants) ++-    [ ""-    , "By default, " ++ show defaultHtmlVariant ++ " is used."-    ]---- | Options for the CLI program----data Arg = ArgHtmlVariant HtmlVariant-         | ArgStandalone-         | ArgIgnoreErrors-         deriving (Show, Eq)---- | A description of the options----options :: [OptDescr Arg]-options =-    [ Option "v" ["html-variant"] htmlVariantOption "HTML variant to use"-    , Option "s" ["standalone"] (NoArg ArgStandalone) "Produce standalone code"-    , Option "e" ["ignore-errors"] (NoArg ArgIgnoreErrors) "Ignore most errors"-    ]-  where-    htmlVariantOption = flip ReqArg "VARIANT" $ \name -> ArgHtmlVariant $-        fromMaybe (error $ "No HTML variant called " ++ name ++ " found.")-                  (M.lookup name htmlVariants)---- | The default HTML variant----defaultHtmlVariant :: HtmlVariant-defaultHtmlVariant = html5
− Util/GenerateHtmlCombinators.hs 
@@ -1,469 +0,0 @@-{-# 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]-    , 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"-                                : "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-                      ++ "\" \"</" ++ 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--- 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", "onblur", "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"-        ]-    , selfClosing = False-    }---- | 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-    ]--main :: IO ()-main = mapM_ (writeHtmlVariant . snd) $ M.toList htmlVariants
− Util/Sanitize.hs 
@@ -1,76 +0,0 @@--- | A program to sanitize an HTML tag to a Haskell function.----module Util.Sanitize-    ( sanitize-    , keywords-    , prelude-    ) where--import Data.Char (toLower, toUpper)-import Data.Set (Set)-import qualified Data.Set as S---- | Sanitize a tag. This function returns a name that can be used as--- combinator in haskell source code.------ Examples:------ > sanitize "class" == "class_"--- > sanitize "http-equiv" == "httpEquiv"----sanitize :: String -> String-sanitize = appendUnderscore . removeDash . map toLower-  where-    -- Remove a dash, replacing it by camelcase notation-    ---    -- Example:-    ---    -- > removeDash "foo-bar" == "fooBar"-    ---    removeDash ('-' : x : xs) = toUpper x : removeDash xs-    removeDash (x : xs) = x : removeDash xs-    removeDash [] = []--    appendUnderscore t | t `S.member` keywords = t ++ "_"-                       | otherwise             = t---- | A set of standard Haskell keywords, which cannot be used as combinators.----keywords :: Set String-keywords = S.fromList-    [ "case", "class", "data", "default", "deriving", "do", "else", "if"-    , "import", "in", "infix", "infixl", "infixr", "instance" , "let", "module"-    , "newtype", "of", "then", "type", "where"-    ]---- | Set of functions from the Prelude, which we do not use as combinators.----prelude :: Set String-prelude = S.fromList-    [ "abs", "acos", "acosh", "all", "and", "any", "appendFile", "asTypeOf"-    , "asin", "asinh", "atan", "atan2", "atanh", "break", "catch", "ceiling"-    , "compare", "concat", "concatMap", "const", "cos", "cosh", "curry", "cycle"-    , "decodeFloat", "div", "divMod", "drop", "dropWhile", "either", "elem"-    , "encodeFloat", "enumFrom", "enumFromThen", "enumFromThenTo", "enumFromTo"-    , "error", "even", "exp", "exponent", "fail", "filter", "flip"-    , "floatDigits", "floatRadix", "floatRange", "floor", "fmap", "foldl"-    , "foldl1", "foldr", "foldr1", "fromEnum", "fromInteger", "fromIntegral"-    , "fromRational", "fst", "gcd", "getChar", "getContents", "getLine", "head"-    , "id", "init", "interact", "ioError", "isDenormalized", "isIEEE"-    , "isInfinite", "isNaN", "isNegativeZero", "iterate", "last", "lcm"-    , "length", "lex", "lines", "log", "logBase", "lookup", "map", "mapM"-    , "mapM_", "max", "maxBound", "maximum", "maybe", "min", "minBound"-    , "minimum", "mod", "negate", "not", "notElem", "null", "odd", "or"-    , "otherwise", "pi", "pred", "print", "product", "properFraction", "putChar"-    , "putStr", "putStrLn", "quot", "quotRem", "read", "readFile", "readIO"-    , "readList", "readLn", "readParen", "reads", "readsPrec", "realToFrac"-    , "recip", "rem", "repeat", "replicate", "return", "reverse", "round"-    , "scaleFloat", "scanl", "scanl1", "scanr", "scanr1", "seq", "sequence"-    , "sequence_", "show", "showChar", "showList", "showParen", "showString"-    , "shows", "showsPrec", "significand", "signum", "sin", "sinh", "snd"-    , "span", "splitAt", "sqrt", "subtract", "succ", "sum", "tail", "take"-    , "takeWhile", "tan", "tanh", "toEnum", "toInteger", "toRational"-    , "truncate", "uncurry", "undefined", "unlines", "until", "unwords", "unzip"-    , "unzip3", "userError", "words", "writeFile", "zip", "zip3", "zipWith"-    , "zipWith3"-    ]
blaze-from-html.cabal view
@@ -1,5 +1,5 @@ Name:          blaze-from-html-Version:       0.3.2.0+Version:       0.3.2.1 Synopsis:      Tool to convert HTML to BlazeHtml code. Description:   Tool that converts HTML files to Haskell code, ready to be                used with the BlazeHtml library.@@ -15,8 +15,9 @@ Cabal-version: >= 1.6  Executable blaze-from-html-  Ghc-Options: -Wall-  Main-Is:     Util/BlazeFromHtml.hs+  Ghc-Options:    -Wall+  Hs-source-dirs: src+  Main-Is:        Util/BlazeFromHtml.hs    Other-Modules:     Util.GenerateHtmlCombinators
+ src/Util/BlazeFromHtml.hs view
@@ -0,0 +1,327 @@+-- | A module for conversion from HTML to BlazeHtml Haskell code.+--+module Main where++import Control.Monad (forM_, when)+import Control.Applicative ((<$>))+import Data.List (stripPrefix)+import Data.Maybe (listToMaybe, fromMaybe)+import Data.Char (toLower, isSpace)+import Control.Arrow (first)+import System.Environment (getArgs)+import System.FilePath (dropExtension)+import qualified Data.Map as M+import System.Console.GetOpt++import Text.HTML.TagSoup++import Util.Sanitize (sanitize)+import Util.GenerateHtmlCombinators hiding (main)++-- | Simple type to represent attributes.+--+type Attributes = [(String, String)]++-- | Intermediate tree representation. This representation contains several+-- constructors aimed at pretty-printing.+--+data Html = Parent String Attributes Html+          | Block [Html]+          | Text String+          | Comment String+          | Doctype+          deriving (Show)++-- | Different combinator types.+--+data CombinatorType = ParentCombinator+                    | LeafCombinator+                    | UnknownCombinator+                    deriving (Eq, Show)++-- | Traverse the list of tags to produce an intermediate representation of the+-- HTML tree.+--+makeTree :: HtmlVariant           -- ^ HTML variant used+         -> Bool                  -- ^ Should ignore errors+         -> [String]              -- ^ Stack of open tags+         -> [Tag String]          -- ^ Tags to parse+         -> (Html, [Tag String])  -- ^ (Result, unparsed part)+makeTree _ ignore stack []+    | null stack || ignore = (Block [], [])+    | otherwise = error $ "Error: tags left open at the end: " ++ show stack+makeTree variant ignore stack (TagPosition row _ : x : xs) = case x of+    TagOpen tag attrs -> if toLower' tag == "!doctype"+        then addHtml Doctype xs+        else let tag' = toLower' tag+                 (inner, t) = case combinatorType variant tag' of+                    LeafCombinator -> (Block [], xs)+                    _ -> makeTree variant ignore (tag' : stack) xs+                 p = Parent tag' (map (first toLower') attrs) inner+             in addHtml p t+    -- The closing tag must match the stack. If it is a closing leaf, we can+    -- ignore it+    TagClose tag ->+        let isLeafCombinator = combinatorType variant tag == LeafCombinator+            matchesStack = listToMaybe stack == Just (toLower' tag)+        in case (isLeafCombinator, matchesStack, ignore) of+            -- It's a leaf combinator, don't care about this element+            (True, _, _)          -> makeTree variant ignore stack xs+            -- It's a parent and the stack doesn't match+            (False, False, False) -> error $+                "Line " ++ show row ++ ": " ++ show tag ++ " closed but "+                        ++ show stack ++ " should be closed instead."+            -- Stack might not match but we ignore it anyway+            (False, _, _)         -> (Block [], xs)+    TagText text -> addHtml (Text text) xs+    TagComment comment -> addHtml (Comment comment) xs+    _ -> makeTree variant ignore stack xs+  where+    addHtml html xs' = let (Block l, r) = makeTree variant ignore stack xs'+                       in (Block (html : l), r)++    toLower' = map toLower+makeTree _ _ _ _ = error "TagSoup error"++-- | Remove empty text from the HTML.+--+removeEmptyText :: Html -> Html+removeEmptyText (Block b) = Block $ map removeEmptyText $ flip filter b $ \h ->+    case h of Text text -> any (not . isSpace) text+              _         -> True+removeEmptyText (Parent tag attrs inner) =+    Parent tag attrs $ removeEmptyText inner+removeEmptyText x = x++-- | Try to eliminiate Block constructors as much as possible.+--+minimizeBlocks :: Html -> Html+minimizeBlocks (Parent t a (Block [x])) = minimizeBlocks $ Parent t a x+minimizeBlocks (Parent t a x) = Parent t a $ minimizeBlocks x+minimizeBlocks (Block x) = Block $ map minimizeBlocks x+minimizeBlocks x = x++-- | Get the type of a combinator, using a given variant.+--+combinatorType :: HtmlVariant -> String -> CombinatorType+combinatorType variant combinator+    | combinator == "docTypeHtml" = ParentCombinator+    | combinator `elem` parents variant = ParentCombinator+    | combinator `elem` leafs variant = LeafCombinator+    | otherwise = UnknownCombinator++-- | Create a special @<html>@ parent that includes the docype.+--+joinHtmlDoctype :: Html -> Html+joinHtmlDoctype (Block (Doctype : Parent "html" attrs inner : xs)) =+    Block $ Parent "docTypeHtml" attrs inner : xs+joinHtmlDoctype x = x++-- | Produce the Blaze code from the HTML. The result is a list of lines.+--+fromHtml :: HtmlVariant  -- ^ Used HTML variant+         -> Bool         -- ^ Should ignore errors+         -> Html         -- ^ HTML tree+         -> [String]     -- ^ Resulting lines of code+fromHtml _ _ Doctype = ["docType"]+fromHtml _ _ (Text text) = ["\"" ++ concatMap escape (trim text) ++ "\""]+  where+    -- Remove whitespace on both ends of a string+    trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace+    -- Escape a number of characters+    escape '"'  = "\\\""+    escape '\n' = "\\n"+    escape x    = [x]+fromHtml _ _ (Comment comment) = map ("-- " ++) $ lines comment+fromHtml variant ignore (Block block) =+    concatMap (fromHtml variant ignore) block+fromHtml variant ignore (Parent tag attrs inner) =+    case combinatorType variant tag of+        -- Actual parent tags+        ParentCombinator -> case inner of+            (Block ls) -> if null ls+                then [combinator +++                        (if null attrs then " " else " $ ") ++ "mempty"]+                else (combinator ++ " $ do") :+                        indent (fromHtml variant ignore inner)+            -- We join non-block parents for better readability.+            x -> let ls = fromHtml variant ignore x+                     apply = if dropApply x then " " else " $ "+                 in case ls of (y : ys) -> (combinator ++ apply ++ y) : ys+                               [] -> [combinator]++        -- Leaf tags+        LeafCombinator -> [combinator]++        -- Unknown tag+        UnknownCombinator -> if ignore+            then fromHtml variant ignore inner+            else error $ "Tag " ++ tag ++ " is illegal in "+                                       ++ show variant+  where+    combinator = qualifiedSanitize "H." tag ++ attributes'+    attributes' = attrs >>= \(k, v) -> case k `elem` attributes variant of+        True  -> " ! " ++ qualifiedSanitize "A." k ++ " " ++ show v+        False -> case stripPrefix "data-" k of+            Just prefix -> " ! "+                        ++ "dataAttribute" ++ " "+                        ++ show prefix+                        ++ " " ++ show v+            Nothing | ignore     -> ""+                    | otherwise  -> error $ "Attribute "+                                 ++ k ++ " is illegal in "+                                 ++ show variant++    -- Qualifies a tag with the given qualifier if needed, and sanitizes it.+    qualifiedSanitize qualifier tag' =+        (if isNameClash variant tag' then qualifier else "") ++ sanitize tag'++    -- Check if we can drop the apply operator ($), for readability reasons.+    -- This would change:+    --+    -- > p $ "Some text"+    --+    -- Into+    --+    -- > p "Some text"+    --+    dropApply (Parent _ _ _) = False+    dropApply (Block _) = False+    dropApply _ = null attrs++-- | Produce the code needed for initial imports.+--+getImports :: HtmlVariant -> [String]+getImports variant =+    [ "{-# LANGUAGE OverloadedStrings #-}"+    , ""+    , import_ "Prelude"+    , qualify "Prelude" "P"+    , import_ "Data.Monoid (mempty)"+    , ""+    , import_ h+    , qualify h "H"+    , import_ a+    , qualify a "A"+    ]+  where+    import_ = ("import " ++)+    qualify name short = "import qualified " ++ name ++ " as " ++ short+    h = getModuleName variant+    a = getAttributeModuleName variant++-- | Convert the HTML to blaze code.+--+blazeFromHtml :: HtmlVariant  -- ^ Variant to use+              -> Bool         -- ^ Produce standalone code+              -> Bool         -- ^ Should we ignore errors+              -> String       -- ^ Template name+              -> String       -- ^ HTML code+              -> String       -- ^ Resulting code+blazeFromHtml variant standalone ignore name =+    unlines . addSignature . fromHtml variant ignore+            . joinHtmlDoctype . minimizeBlocks+            . removeEmptyText . fst . makeTree variant ignore []+            . parseTagsOptions parseOptions { optTagPosition = True }+  where+    addSignature body = if standalone then [ name ++ " :: Html"+                                           , name ++ " = do"+                                           ] ++ indent body+                                      else body++-- | Indent block of code.+--+indent :: [String] -> [String]+indent = map ("    " ++)++-- | Main function+--+main :: IO ()+main = do+    args <- getOpt Permute options <$> getArgs+    case args of+        (o, n, []) -> let v = getVariant o+                          s = standalone' o+                          i = ignore' o+                      in do imports' v o+                            main' v s i n+        (_, _, _)  -> putStr help+  where+    -- No files given, work with stdin+    main' variant standalone ignore [] = interact $+        blazeFromHtml variant standalone ignore "template"++    -- Handle all files+    main' variant standalone ignore files = forM_ files $ \file -> do+        body <- readFile file+        putStrLn $ blazeFromHtml variant standalone ignore+                                 (dropExtension file) body++    -- Print imports if needed+    imports' variant opts = when (standalone' opts) $+        putStrLn $ unlines $ getImports variant++    -- Should we produce standalone code?+    standalone' opts = ArgStandalone `elem` opts++    -- Should we ignore errors?+    ignore' opts = ArgIgnoreErrors `elem` opts++    -- Get the variant from the options+    getVariant opts = fromMaybe defaultHtmlVariant $ listToMaybe $+        flip concatMap opts $ \o -> case o of (ArgHtmlVariant x) -> [x]+                                              _ -> []++-- | Help information.+--+help :: String+help = unlines $+    [ "This is a tool to convert HTML code to BlazeHtml code. It is still"+    , "experimental and the results might need to be edited manually."+    , ""+    , "USAGE"+    , ""+    , "  blaze-from-html [OPTIONS...] [FILES ...]"+    , ""+    , "When no files are given, it works as a filter."+    , ""+    , "EXAMPLE"+    , ""+    , "  blaze-from-html -v html4-strict index.html"+    , ""+    , "This converts the index.html file to Haskell code, writing to stdout."+    , ""+    , "OPTIONS"+    , usageInfo "" options+    , "VARIANTS"+    , ""+    ] +++    map (("  " ++) . fst) (M.toList htmlVariants) +++    [ ""+    , "By default, " ++ show defaultHtmlVariant ++ " is used."+    ]++-- | Options for the CLI program+--+data Arg = ArgHtmlVariant HtmlVariant+         | ArgStandalone+         | ArgIgnoreErrors+         deriving (Show, Eq)++-- | A description of the options+--+options :: [OptDescr Arg]+options =+    [ Option "v" ["html-variant"] htmlVariantOption "HTML variant to use"+    , Option "s" ["standalone"] (NoArg ArgStandalone) "Produce standalone code"+    , Option "e" ["ignore-errors"] (NoArg ArgIgnoreErrors) "Ignore most errors"+    ]+  where+    htmlVariantOption = flip ReqArg "VARIANT" $ \name -> ArgHtmlVariant $+        fromMaybe (error $ "No HTML variant called " ++ name ++ " found.")+                  (M.lookup name htmlVariants)++-- | The default HTML variant+--+defaultHtmlVariant :: HtmlVariant+defaultHtmlVariant = html5
+ src/Util/GenerateHtmlCombinators.hs view
@@ -0,0 +1,470 @@+{-# 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]+    , 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 $ 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+                      ++ "\" \"</" ++ 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+-- 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", "onblur", "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"+        ]+    , selfClosing = False+    }++-- | 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+    ]++main :: IO ()+main = mapM_ (writeHtmlVariant . snd) $ M.toList htmlVariants
+ src/Util/Sanitize.hs view
@@ -0,0 +1,80 @@+-- | A program to sanitize an HTML tag to a Haskell function.+--+module Util.Sanitize+    ( sanitize+    , keywords+    , prelude+    ) where++import Data.Char (toLower, toUpper)+import Data.Set (Set)+import qualified Data.Set as S++-- | Sanitize a tag. This function returns a name that can be used as+-- combinator in haskell source code.+--+-- Examples:+--+-- > sanitize "class" == "class_"+-- > sanitize "http-equiv" == "httpEquiv"+--+sanitize :: String -> String+sanitize str+    | lower  == "doctypehtml" = "docTypeHtml"+    | otherwise               = appendUnderscore $ removeDash lower+  where+    lower = map toLower str++    -- Remove a dash, replacing it by camelcase notation+    --+    -- Example:+    --+    -- > removeDash "foo-bar" == "fooBar"+    --+    removeDash ('-' : x : xs) = toUpper x : removeDash xs+    removeDash (x : xs) = x : removeDash xs+    removeDash [] = []++    appendUnderscore t | t `S.member` keywords = t ++ "_"+                       | otherwise             = t++-- | A set of standard Haskell keywords, which cannot be used as combinators.+--+keywords :: Set String+keywords = S.fromList+    [ "case", "class", "data", "default", "deriving", "do", "else", "if"+    , "import", "in", "infix", "infixl", "infixr", "instance" , "let", "module"+    , "newtype", "of", "then", "type", "where"+    ]++-- | Set of functions from the Prelude, which we do not use as combinators.+--+prelude :: Set String+prelude = S.fromList+    [ "abs", "acos", "acosh", "all", "and", "any", "appendFile", "asTypeOf"+    , "asin", "asinh", "atan", "atan2", "atanh", "break", "catch", "ceiling"+    , "compare", "concat", "concatMap", "const", "cos", "cosh", "curry", "cycle"+    , "decodeFloat", "div", "divMod", "drop", "dropWhile", "either", "elem"+    , "encodeFloat", "enumFrom", "enumFromThen", "enumFromThenTo", "enumFromTo"+    , "error", "even", "exp", "exponent", "fail", "filter", "flip"+    , "floatDigits", "floatRadix", "floatRange", "floor", "fmap", "foldl"+    , "foldl1", "foldr", "foldr1", "fromEnum", "fromInteger", "fromIntegral"+    , "fromRational", "fst", "gcd", "getChar", "getContents", "getLine", "head"+    , "id", "init", "interact", "ioError", "isDenormalized", "isIEEE"+    , "isInfinite", "isNaN", "isNegativeZero", "iterate", "last", "lcm"+    , "length", "lex", "lines", "log", "logBase", "lookup", "map", "mapM"+    , "mapM_", "max", "maxBound", "maximum", "maybe", "min", "minBound"+    , "minimum", "mod", "negate", "not", "notElem", "null", "odd", "or"+    , "otherwise", "pi", "pred", "print", "product", "properFraction", "putChar"+    , "putStr", "putStrLn", "quot", "quotRem", "read", "readFile", "readIO"+    , "readList", "readLn", "readParen", "reads", "readsPrec", "realToFrac"+    , "recip", "rem", "repeat", "replicate", "return", "reverse", "round"+    , "scaleFloat", "scanl", "scanl1", "scanr", "scanr1", "seq", "sequence"+    , "sequence_", "show", "showChar", "showList", "showParen", "showString"+    , "shows", "showsPrec", "significand", "signum", "sin", "sinh", "snd"+    , "span", "splitAt", "sqrt", "subtract", "succ", "sum", "tail", "take"+    , "takeWhile", "tan", "tanh", "toEnum", "toInteger", "toRational"+    , "truncate", "uncurry", "undefined", "unlines", "until", "unwords", "unzip"+    , "unzip3", "userError", "words", "writeFile", "zip", "zip3", "zipWith"+    , "zipWith3"+    ]