blaze-from-html (empty) → 0.2
raw patch · 4 files changed
+362/−0 lines, 4 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, filepath, tagsoup
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Util/BlazeFromHtml.hs +306/−0
- blaze-from-html.cabal +24/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Util/BlazeFromHtml.hs view
@@ -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 @<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) -> 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
+ blaze-from-html.cabal view
@@ -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