diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Jasper Van der Jeugt 2010 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jasper Van der Jeugt nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Util/BlazeFromHtml.hs b/Util/BlazeFromHtml.hs new file mode 100644 --- /dev/null +++ b/Util/BlazeFromHtml.hs @@ -0,0 +1,306 @@ +-- | A module for conversion from HTML to BlazeHtml Haskell code. +-- +module Main where + +import Control.Monad (forM_, when) +import Control.Applicative ((<$>)) +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 + +-- | 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 (Show) + +-- | Traverse the list of tags to produce an intermediate representation of the +-- HTML tree. +-- +makeTree :: 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 ignore stack (TagPosition row _ : x : xs) = case x of + TagOpen tag attrs -> if toLower' tag == "!doctype" + then addHtml Doctype xs + else let (inner, t) = makeTree ignore (tag : stack) xs + p = Parent (toLower' tag) (map (first toLower') attrs) inner + in addHtml p t + -- The closing tag must match the stack. + TagClose tag -> if listToMaybe stack == Just (toLower' tag) || ignore + then (Block [], xs) + else error $ "Line " ++ show row ++ ": " ++ show tag ++ " closed but " + ++ show stack ++ " should be closed instead." + TagText text -> addHtml (Text text) xs + TagComment comment -> addHtml (Comment comment) xs + _ -> makeTree ignore stack xs + where + addHtml html xs' = let (Block l, r) = makeTree 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 @@ 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) -> if k `elem` attributes variant + then " ! " ++ qualifiedSanitize "A." k ++ " " ++ show v + else if ignore + then "" + else 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 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 diff --git a/blaze-from-html.cabal b/blaze-from-html.cabal new file mode 100644 --- /dev/null +++ b/blaze-from-html.cabal @@ -0,0 +1,24 @@ +Name: blaze-from-html +Version: 0.2 +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. +Homepage: http://jaspervdj.be/blaze +Bug-Reports: http://github.com/jaspervdj/BlazeHtml/issues +License: BSD3 +License-file: LICENSE +Author: Jasper Van der Jeugt, Simon Meier +Maintainer: jaspervdj@gmail.com, simon.meier@inf.ethz.ch +Stability: Experimental +Category: Text +Build-type: Simple +Cabal-version: >= 1.2 + +Executable blaze-from-html + Ghc-Options: -Wall + Main-Is: Util/BlazeFromHtml.hs + Build-depends: base >= 4 && < 5, + containers >= 0.3, + filepath >= 1.1, + directory >= 1.0, + tagsoup >= 0.10