diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -2,8 +2,12 @@ ( -- * Basic quasiquoters hamlet , xhamlet - -- * Build customized quasiquoters + -- * Load from external file + , hamletFile + , xhamletFile + -- * Customized settings , hamletWithSettings + , hamletFileWithSettings , HamletSettings (..) , defaultHamletSettings -- * Datatypes diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} module Text.Hamlet.Parse ( Result (..) @@ -9,23 +8,15 @@ , parseDoc , HamletSettings (..) , defaultHamletSettings -#if TEST - , testSuite -#endif ) where -import Control.Applicative +import Control.Applicative ((<$>), Applicative (..)) import Control.Monad import Control.Arrow import Data.Data import Data.List (intercalate) - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -#endif +import Text.ParserCombinators.Parsec hiding (Line) data Result v = Error String | Ok v deriving (Show, Eq, Read, Data, Typeable) @@ -67,227 +58,156 @@ deriving (Eq, Show, Read) parseLines :: HamletSettings -> String -> Result [(Int, Line)] -parseLines set = mapM (go . killCarriage) . lines where - go s = do - let (spaces, s') = countSpaces 0 s - l <- parseLine set $ killTrailingDollar s' - Ok (spaces, l) - countSpaces i (' ':rest) = countSpaces (i + 1) rest - countSpaces i ('\t':rest) = countSpaces (i + 4) rest - countSpaces i x = (i, x) - killCarriage s - | null s = s - | last s == '\r' = init s - | otherwise = s - killTrailingDollar "" = "" - killTrailingDollar x - | last x == '$' && odd (length $ filter (== '$') x) = init x - | otherwise = x - -parseLine :: HamletSettings -> String -> Result Line -parseLine set "!!!" = - Ok $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] -parseLine _ "\\" = Ok $ LineContent [ContentRaw "\n"] -parseLine _ ('\\':s) = LineContent <$> parseContent s -parseLine _ ('$':'f':'o':'r':'a':'l':'l':' ':rest) = - case words rest of - [x, y] -> do - x' <- parseDeref x - y' <- parseIdent y - return $ LineForall x' y' - _ -> Error $ "Invalid forall: " ++ rest -parseLine _ ('$':'i':'f':' ':rest) = LineIf <$> parseDeref rest -parseLine _ ('$':'e':'l':'s':'e':'i':'f':' ':rest) = - LineElseIf <$> parseDeref rest -parseLine _ "$else" = Ok LineElse -parseLine _ ('$':'m':'a':'y':'b':'e':' ':rest) = - case words rest of - [x, y] -> do - x' <- parseDeref x - y' <- parseIdent y - return $ LineMaybe x' y' - _ -> Error $ "Invalid maybe: " ++ rest -parseLine _ "$nothing" = Ok LineNothing -parseLine _ x@(c:_) | c `elem` "%#." = do - let (begin, rest) = break (== ' ') x - rest' = dropWhile (== ' ') rest - (tn, attr, classes) <- parseTag begin - con <- parseContent rest' - return $ LineTag tn attr con classes -parseLine _ s = LineContent <$> parseContent s - -#if TEST -fooBar :: Deref -fooBar = Deref [Ident "bar", Ident "foo"] - -caseParseLine :: Assertion -caseParseLine = do - let parseLine' = parseLine defaultHamletSettings - parseLine' "$if foo.bar" @?= Ok (LineIf fooBar) - parseLine' "$elseif foo.bar" @?= Ok (LineElseIf fooBar) - parseLine' "$else" @?= Ok LineElse - parseLine' "%img!src=@foo.bar@" - @?= Ok (LineTag "img" [(Nothing, "src", [ContentUrl False fooBar])] [] []) - parseLine' "%img!src=@?foo.bar@" - @?= Ok (LineTag "img" [(Nothing, "src", [ContentUrl True fooBar])] [] []) - parseLine' ".$foo.bar$" - @?= Ok (LineTag "div" [] [] [[ContentVar fooBar]]) - parseLine' "%span#foo.bar.bar2!baz=bin" - @?= Ok (LineTag "span" [ (Nothing, "id", [ContentRaw "foo"]) - , (Nothing, "baz", [ContentRaw "bin"]) - ] [] - [ [ContentRaw "bar"] - , [ContentRaw "bar2"] - ]) - parseLine' "\\#this is raw" - @?= Ok (LineContent [ContentRaw "#this is raw"]) - parseLine' "\\" - @?= Ok (LineContent [ContentRaw "\n"]) - parseLine' "%img!:baz:src=@foo.bar@" - @?= Ok (LineTag "img" - [(Just $ Deref [Ident "baz"], - "src", - [ContentUrl False fooBar])] [] []) -#endif - -parseContent :: String -> Result [Content] -parseContent "" = Ok [] -parseContent s = - case break (flip elem "@$^") s of - (_, "") -> Ok [ContentRaw s] - (a, delim:a') -> do - b <- - case break (== delim) a' of - ("", _:rest) -> do - rest' <- parseContent rest - return $ ContentRaw [delim] : rest' - (deref, _:rest) -> do - let (x, deref') = case delim of - '$' -> (ContentVar, deref) - '@' -> - case deref of - '?':y -> (ContentUrl True, y) - _ -> (ContentUrl False, deref) - '^' -> (ContentEmbed, deref) - _ -> error $ "Invalid delim in parseContent: " ++ [delim] - deref'' <- parseDeref deref' - rest' <- parseContent rest - return $ x deref'' : rest' - (_, "") -> error $ "Missing ending delimiter in " ++ s - case a of - "" -> return b - _ -> return $ ContentRaw a : b - -#if TEST -caseParseContent :: Assertion -caseParseContent = do - parseContent "" @?= Ok [] - parseContent "foo" @?= Ok [ContentRaw "foo"] - parseContent "foo $bar$ baz" @?= Ok [ ContentRaw "foo " - , ContentVar $ Deref [Ident "bar"] - , ContentRaw " baz" - ] - parseContent "foo @bar@ baz" @?= - Ok [ ContentRaw "foo " - , ContentUrl False (Deref [Ident "bar"]) - , ContentRaw " baz" - ] - parseContent "foo @?bar@ baz" @?= - Ok [ ContentRaw "foo " - , ContentUrl True (Deref [Ident "bar"]) - , ContentRaw " baz" - ] - parseContent "foo ^bar^ baz" @?= Ok [ ContentRaw "foo " - , ContentEmbed $ Deref [Ident "bar"] - , ContentRaw " baz" - ] - parseContent "@@" @?= Ok [ContentRaw "@"] - parseContent "^^" @?= Ok [ContentRaw "^"] -#endif - -parseDeref :: String -> Result Deref -parseDeref "" = Error "Invalid empty deref" -parseDeref s = Deref . reverse <$> go s where - go a = case break (== '.') a of - (x, '.':y) -> do - x' <- parseIdent x - y' <- go y - return $ x' : y' - (x, "") -> return <$> parseIdent x - _ -> Error "Invalid branch in Text.Hamlet.Parse.parseDef" - -#if TEST -caseParseDeref :: Assertion -caseParseDeref = do - parseDeref "baz.bar.foo" @?= - Ok (Deref [ Ident "foo" - , Ident "bar" - , Ident "baz"]) -#endif - -parseIdent :: String -> Result Ident -parseIdent "" = Error "Invalid empty ident" -parseIdent s - | all (flip elem (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'")) s - = Ok $ Ident s - | otherwise = Error $ "Invalid identifier: " ++ s - -#if TEST -caseParseIdent :: Assertion -caseParseIdent = parseIdent "foo" @?= Ok (Ident "foo") -#endif +parseLines set s = + case parse (many $ parseLine set) s s of + Left e -> Error $ show e + Right x -> Ok x -parseTag :: String -> Result - (String, - [(Maybe Deref, String, [Content])], - [[Content]]) -parseTag s = do - pieces <- takePieces s - (a, b, c) <- foldM go ("div", id, id) pieces - return (a, b [], c []) +parseLine :: HamletSettings -> Parser (Int, Line) +parseLine set = do + ss <- fmap sum $ many ((char ' ' >> return 1) <|> + (char '\t' >> return 4)) + x <- doctype <|> + backslash <|> + try controlIf <|> + try controlElseIf <|> + try (string "$else" >> eol >> return LineElse) <|> + try controlMaybe <|> + try (string "$nothing" >> eol >> return LineNothing) <|> + try controlForall <|> + tag <|> + (do + cs <- content InContent + isEof <- (eof >> return True) <|> return False + if null cs && ss == 0 && isEof + then fail "End of Hamlet template" + else return $ LineContent cs) + return (ss, x) where - go (_, attrs, classes) (_, '%':tn) = Ok (tn, attrs, classes) - go (tn, attrs, classes) (_, '.':cl) = do - con <- parseContent cl - Ok (tn, attrs, classes . (:) con) - go (tn, attrs, classes) (_, '#':cl) = do - con <- parseContent cl - Ok (tn, attrs . (:) (Nothing, "id", con), classes) - go (tn, attrs, classes) (cond, '!':rest) = do - let (name, val) = break (== '=') rest - val' <- case val of - '=':x -> parseContent x - _ -> Ok [] - cond' <- case cond of - Nothing -> return Nothing - Just x -> Just <$> parseDeref x - Ok (tn, attrs . (:) (cond', name, val'), classes) - go _ _ = error "Invalid branch in Text.Hamlet.Parse.parseTag" + eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) + eol = eof <|> eol' + doctype = do + string "!!!" >> eol + return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] + backslash = do + _ <- char '\\' + (eol >> return (LineContent [ContentRaw "\n"])) + <|> (LineContent <$> content InContent) + controlIf = do + _ <- string "$if" + spaces + x <- deref False + eol + return $ LineIf x + controlElseIf = do + _ <- string "$elseif" + spaces + x <- deref False + eol + return $ LineElseIf x + controlMaybe = do + _ <- string "$maybe" + spaces + x <- deref False + spaces + y <- ident + eol + return $ LineMaybe x y + controlForall = do + _ <- string "$forall" + spaces + x <- deref False + spaces + y <- ident + eol + return $ LineForall x y + tag = do + x <- tagName <|> tagIdent <|> tagClass + xs <- many $ tagIdent <|> tagClass <|> tagAttrib + c <- (eol >> return []) <|> (do + _ <- many1 $ oneOf " \t" + content InContent) + let (tn, attr, classes) = tag' $ x : xs + return $ LineTag tn attr c classes + content cr = do + x <- many $ content' cr + case cr of + InQuotes -> char '"' >> return () + NotInQuotes -> return () + InContent -> (char '$' >> eol) <|> eol + return x + content' cr = try contentDollar <|> contentAt <|> contentCarrot + <|> contentReg cr + contentDollar = do + _ <- char '$' + (char '$' >> return (ContentRaw "$")) <|> (do + s <- deref True + _ <- char '$' + return $ ContentVar s) + contentAt = do + _ <- char '@' + (char '@' >> return (ContentRaw "@")) <|> (do + x <- (char '?' >> return True) <|> return False + s <- deref True + _ <- char '@' + return $ ContentUrl x s) + contentCarrot = do + _ <- char '^' + (char '^' >> return (ContentRaw "^")) <|> (do + s <- deref True + _ <- char '^' + return $ ContentEmbed s) + contentReg InContent = ContentRaw <$> many1 (noneOf "$@^\r\n") + contentReg NotInQuotes = ContentRaw <$> many1 (noneOf "$@^#.! \t\n\r") + contentReg InQuotes = + (do + _ <- char '\\' + ContentRaw . return <$> anyChar + ) <|> (ContentRaw <$> many1 (noneOf "$@^\\\"\n\r")) + tagName = do + _ <- char '%' + s <- many1 $ noneOf " \t.#!\r\n" + return $ TagName s + tagAttribValue = do + cr <- (char '"' >> return InQuotes) <|> return NotInQuotes + content cr + tagIdent = char '#' >> TagIdent <$> tagAttribValue + tagClass = char '.' >> TagClass <$> tagAttribValue + tagAttrib = do + _ <- char '!' + cond <- (Just <$> tagAttribCond) <|> return Nothing + s <- many1 $ noneOf " \t.!=\r\n" + v <- (do + _ <- char '=' + s' <- tagAttribValue + return s') <|> return [] + return $ TagAttrib (cond, s, v) + tagAttribCond = do + _ <- char ':' + d <- deref True + _ <- char ':' + return d + tag' = foldr tag'' ("div", [], []) + tag'' (TagName s) (_, y, z) = (s, y, z) + tag'' (TagIdent s) (x, y, z) = (x, (Nothing, "id", s) : y, z) + tag'' (TagClass s) (x, y, z) = (x, y, s : z) + tag'' (TagAttrib s) (x, y, z) = (x, s : y, z) + deref spaceAllowed = do + let delim = if spaceAllowed + then (char '.' <|> (many1 (char ' ') >> return ' ')) + else char '.' + x <- ident + xs <- many $ delim >> ident + return $ Deref $ x : xs + ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'') -takePieces :: String -> Result [(Maybe String, String)] -takePieces "" = Ok [] -takePieces (a:s) = do - let (cond, s') = - case (a, s) of - ('!', ':':rest) -> - case break (== ':') rest of - (x, ':':y) -> (Just x, y) - _ -> (Nothing, s) - _ -> (Nothing, s) - (x, y) <- takePiece ((:) a) False False False s' - y' <- takePieces y - return $ (cond, x) : y' - where - takePiece front False False False "" = Ok (front "", "") - takePiece _ _ _ _ "" = Error $ "Unterminated URL, var or embed: " ++ s - takePiece front False False False (c:rest) - | c `elem` "#.%!" = Ok (front "", c:rest) - takePiece front x y z (c:rest) - | c == '$' = takePiece (front . (:) c) (not x) y z rest - | c == '@' = takePiece (front . (:) c) x (not y) z rest - | c == '^' = takePiece (front . (:) c) x y (not z) rest - | otherwise = takePiece (front . (:) c) x y z rest +data TagPiece = TagName String + | TagIdent [Content] + | TagClass [Content] + | TagAttrib (Maybe Deref, String, [Content]) +data ContentRule = InQuotes | NotInQuotes | InContent + data Nest = Nest Line [Nest] nestLines :: [(Int, Line)] -> [Nest] @@ -436,14 +356,3 @@ inside' <- nestToDoc set inside parseConds set (front . (:) (d, inside')) rest parseConds _ front rest = Ok (front [], Nothing, rest) - -#if TEST ----- Testing -testSuite :: Test -testSuite = testGroup "Text.Hamlet.Parse" - [ testCase "parseLine" caseParseLine - , testCase "parseContent" caseParseContent - , testCase "parseDeref" caseParseDeref - , testCase "parseIdent" caseParseIdent - ] -#endif diff --git a/Text/Hamlet/Quasi.hs b/Text/Hamlet/Quasi.hs --- a/Text/Hamlet/Quasi.hs +++ b/Text/Hamlet/Quasi.hs @@ -1,8 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module Text.Hamlet.Quasi ( hamlet , xhamlet , hamletWithSettings + , hamletFile + , xhamletFile + , hamletFileWithSettings ) where import Text.Hamlet.Parse @@ -15,6 +20,13 @@ import Text.Blaze (unsafeByteString, Html, string) import Data.List (intercalate) +class ToHtml a where + toHtml :: a -> Html () +instance ToHtml String where + toHtml = string +instance ToHtml (Html a) where + toHtml x = x >> return () + type Scope = [(Ident, Exp)] docsToExp :: Exp -> Scope -> [Doc] -> Q Exp @@ -78,7 +90,9 @@ os <- [|unsafeByteString . S8.pack|] let s' = LitE $ StringL $ S8.unpack $ BSU.fromString s return $ os `AppE` s' -contentToExp _ scope (ContentVar d) = return $ deref scope d +contentToExp _ scope (ContentVar d) = do + str <- [|toHtml|] + return $ str `AppE` deref scope d contentToExp render scope (ContentUrl hasParams d) = do ou <- if hasParams then [|outputUrlParams|] else [|outputUrl|] let d' = deref scope d @@ -105,24 +119,46 @@ -- Please see accompanying documentation for a description of Hamlet syntax. hamletWithSettings :: HamletSettings -> QuasiQuoter hamletWithSettings set = - QuasiQuoter go $ error "Cannot quasi-quote Hamlet to patterns" + QuasiQuoter (hamletFromString set) + $ error "Cannot quasi-quote Hamlet to patterns" + +hamletFromString :: HamletSettings -> String -> Q Exp +hamletFromString set s = do + case parseDoc set s of + Error s' -> error s' + Ok d -> do + render <- newName "_render" + func <- docsToExp (VarE render) [] d + return $ LamE [VarP render] func + +hamletFileWithSettings :: HamletSettings -> FilePath -> Q Exp +hamletFileWithSettings set fp = do + contents <- fmap BSU.toString $ qRunIO $ S8.readFile fp + hamletFromString set contents + +-- | Calls 'hamletFileWithSettings' with 'defaultHamletSettings'. +hamletFile :: FilePath -> Q Exp +hamletFile = hamletFileWithSettings defaultHamletSettings + +-- | Calls 'hamletFileWithSettings' using XHTML 1.0 Strict settings. +xhamletFile :: FilePath -> Q Exp +xhamletFile = + hamletFileWithSettings $ HamletSettings doctype True where - go s = do - case parseDoc set s of - Error s' -> error s' - Ok d -> do - render <- newName "_render" - func <- docsToExp (VarE render) [] d - return $ LamE [VarP render] func + doctype = + "" deref :: Scope -> Deref -> Exp deref _ (Deref []) = error "Invalid empty deref" -deref scope (Deref (z@(Ident zName):y)) = +deref scope (Deref d) = let z' = case lookup z scope of Nothing -> varName zName Just zExp -> zExp - in foldr go z' $ reverse y + in foldr go z' y where + z@(Ident zName) = last d + y = init d varName "" = error "Illegal empty varName" varName v@(s:_) = case lookup (Ident v) scope of diff --git a/hamlet.cabal b/hamlet.cabal --- a/hamlet.cabal +++ b/hamlet.cabal @@ -1,5 +1,5 @@ name: hamlet -version: 0.3.1.1 +version: 0.4.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -43,7 +43,8 @@ bytestring >= 0.9 && < 0.10, utf8-string >= 0.3.4 && < 0.4, template-haskell, - blaze-html >= 0.1 && < 0.2 + blaze-html >= 0.1.1 && < 0.2, + parsec >= 2 && < 4 exposed-modules: Text.Hamlet other-modules: Text.Hamlet.Parse Text.Hamlet.Quasi diff --git a/runtests.hs b/runtests.hs --- a/runtests.hs +++ b/runtests.hs @@ -1,292 +1,376 @@ -{-# LANGUAGE QuasiQuotes #-} -import Test.Framework (defaultMain, testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) - -import qualified Text.Hamlet.Parse -import Text.Hamlet -import Data.ByteString.UTF8 (fromString) -import Data.ByteString.Lazy.UTF8 (toString) - -main :: IO () -main = defaultMain - [ Text.Hamlet.Parse.testSuite - , testSuite - ] - -testSuite :: Test -testSuite = testGroup "Text.Hamlet" - [ testCase "empty" caseEmpty - , testCase "static" caseStatic - , testCase "tag" caseTag - , testCase "var" caseVar - , testCase "var chain " caseVarChain - , testCase "url" caseUrl - , testCase "url chain " caseUrlChain - , testCase "embed" caseEmbed - , testCase "embed chain " caseEmbedChain - , testCase "if" caseIf - , testCase "if chain " caseIfChain - , testCase "else" caseElse - , testCase "else chain " caseElseChain - , testCase "elseif" caseElseIf - , testCase "elseif chain " caseElseIfChain - , testCase "list" caseList - , testCase "list chain" caseListChain - , testCase "script not empty" caseScriptNotEmpty - , testCase "meta empty" caseMetaEmpty - , testCase "input empty" caseInputEmpty - , testCase "multiple classes" caseMultiClass - , testCase "attrib order" caseAttribOrder - , testCase "nothing" caseNothing - , testCase "nothing chain " caseNothingChain - , testCase "just" caseJust - , testCase "just chain " caseJustChain - , testCase "constructor" caseConstructor - , testCase "url + params" caseUrlParams - , testCase "escape" caseEscape - , testCase "empty statement list" caseEmptyStatementList - , testCase "attribute conditionals" caseAttribCond - , testCase "non-ascii" caseNonAscii - , testCase "maybe function" caseMaybeFunction - , testCase "trailing dollar sign" caseTrailingDollarSign - ] - -data Url = Home | Sub SubUrl -data SubUrl = SubUrl -render :: Url -> String -render Home = "url" -render (Sub SubUrl) = "suburl" - -data Arg url = Arg - { getArg :: Arg url - , var :: Html () - , url :: Url - , embed :: Hamlet url - , true :: Bool - , false :: Bool - , list :: [Arg url] - , nothing :: Maybe (Html ()) - , just :: Maybe (Html ()) - , urlParams :: (Url, [(String, String)]) - } - -theArg :: Arg url -theArg = Arg - { getArg = theArg - , var = string "" - , url = Home - , embed = [$hamlet|embed|] - , true = True - , false = False - , list = [theArg, theArg, theArg] - , nothing = Nothing - , just = Just $ string "just" - , urlParams = (Home, [("foo", "bar"), ("foo1", "bar1")]) - } - -helper :: String -> Hamlet Url -> Assertion -helper res h = do - let x = renderHamlet render h - res @=? toString x - -caseEmpty :: Assertion -caseEmpty = helper "" [$hamlet||] - -caseStatic :: Assertion -caseStatic = helper "some static content" [$hamlet|some static content|] - -caseTag :: Assertion -caseTag = helper "

baz

" [$hamlet| -%p.foo - #bar baz|] - -caseVar :: Assertion -caseVar = do - helper "<var>" [$hamlet|$var.theArg$|] - -caseVarChain :: Assertion -caseVarChain = do - helper "<var>" [$hamlet|$var.getArg.getArg.getArg.theArg$|] - -caseUrl :: Assertion -caseUrl = do - helper (render Home) [$hamlet|@url.theArg@|] - -caseUrlChain :: Assertion -caseUrlChain = do - helper (render Home) [$hamlet|@url.getArg.getArg.getArg.theArg@|] - -caseEmbed :: Assertion -caseEmbed = do - helper "embed" [$hamlet|^embed.theArg^|] - -caseEmbedChain :: Assertion -caseEmbedChain = do - helper "embed" [$hamlet|^embed.getArg.getArg.getArg.theArg^|] - -caseIf :: Assertion -caseIf = do - helper "if" [$hamlet| -$if true.theArg - if -|] - -caseIfChain :: Assertion -caseIfChain = do - helper "if" [$hamlet| -$if true.getArg.getArg.getArg.theArg - if -|] - -caseElse :: Assertion -caseElse = helper "else" [$hamlet| -$if false.theArg - if -$else - else -|] - -caseElseChain :: Assertion -caseElseChain = helper "else" [$hamlet| -$if false.getArg.getArg.getArg.theArg - if -$else - else -|] - -caseElseIf :: Assertion -caseElseIf = helper "elseif" [$hamlet| -$if false.theArg - if -$elseif true.theArg - elseif -$else - else -|] - -caseElseIfChain :: Assertion -caseElseIfChain = helper "elseif" [$hamlet| -$if false.getArg.getArg.getArg.theArg - if -$elseif true.getArg.getArg.getArg.theArg - elseif -$else - else -|] - -caseList :: Assertion -caseList = do - helper "xxx" [$hamlet| -$forall list.theArg x - x -|] - -caseListChain :: Assertion -caseListChain = do - helper "urlurlurl" [$hamlet| -$forall list.getArg.getArg.getArg.getArg.getArg.theArg x - @url.x@ -|] - -caseScriptNotEmpty :: Assertion -caseScriptNotEmpty = helper "" [$hamlet|%script|] - -caseMetaEmpty :: Assertion -caseMetaEmpty = do - helper "" [$hamlet|%meta|] - helper "" [$xhamlet|%meta|] - -caseInputEmpty :: Assertion -caseInputEmpty = do - helper "" [$hamlet|%input|] - helper "" [$xhamlet|%input|] - -caseMultiClass :: Assertion -caseMultiClass = do - helper "
" [$hamlet|.foo.bar|] - -caseAttribOrder :: Assertion -caseAttribOrder = helper "" [$hamlet|%meta!1!2!3|] - -caseNothing :: Assertion -caseNothing = do - helper "" [$hamlet| -$maybe nothing.theArg n - nothing -|] - helper "nothing" [$hamlet| -$maybe nothing.theArg n - something -$nothing - nothing -|] - -caseNothingChain :: Assertion -caseNothingChain = helper "" [$hamlet| -$maybe nothing.getArg.getArg.getArg.theArg n - nothing $n$ -|] - -caseJust :: Assertion -caseJust = helper "it's just" [$hamlet| -$maybe just.theArg n - it's $n$ -|] - -caseJustChain :: Assertion -caseJustChain = helper "it's just" [$hamlet| -$maybe just.getArg.getArg.getArg.theArg n - it's $n$ -|] - -caseConstructor :: Assertion -caseConstructor = do - helper "url" [$hamlet|@Home@|] - helper "suburl" [$hamlet|@Sub.SubUrl@|] - let text = "" - helper "" [$hamlet|$preEscapedString.text$|] - -caseUrlParams :: Assertion -caseUrlParams = do - helper "url?foo=bar&foo1=bar1" [$hamlet|@?urlParams.theArg@|] - -caseEscape :: Assertion -caseEscape = do - helper "#this is raw\n " [$hamlet| -\#this is raw -\ -\ -|] - -caseEmptyStatementList :: Assertion -caseEmptyStatementList = do - helper "" [$hamlet|$if True|] - helper "" [$hamlet|$maybe Nothing x|] - let emptyList = [] - helper "" [$hamlet|$forall emptyList x|] - -caseAttribCond :: Assertion -caseAttribCond = do - helper "" [$hamlet|%select!:False:selected|] - helper "" [$hamlet|%select!:True:selected|] - helper "" [$hamlet|%meta!var=foo:bar|] - helper "" - [$hamlet|%select!:true.theArg:selected|] - -caseNonAscii :: Assertion -caseNonAscii = do - helper "עִבְרִי" [$hamlet|עִבְרִי|] - -caseMaybeFunction :: Assertion -caseMaybeFunction = do - helper "url?foo=bar&foo1=bar1" [$hamlet| -$maybe Just.urlParams x - @?x.theArg@ -|] - -caseTrailingDollarSign :: Assertion -caseTrailingDollarSign = - helper "trailing space \ndollar sign $" [$hamlet|trailing space $ -\ -dollar sign $$|] +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import Text.Hamlet +import Data.ByteString.Lazy.UTF8 (toString) + +main :: IO () +main = defaultMain [testSuite] + +testSuite :: Test +testSuite = testGroup "Text.Hamlet" + [ testCase "empty" caseEmpty + , testCase "static" caseStatic + , testCase "tag" caseTag + , testCase "var" caseVar + , testCase "var chain " caseVarChain + , testCase "url" caseUrl + , testCase "url chain " caseUrlChain + , testCase "embed" caseEmbed + , testCase "embed chain " caseEmbedChain + , testCase "if" caseIf + , testCase "if chain " caseIfChain + , testCase "else" caseElse + , testCase "else chain " caseElseChain + , testCase "elseif" caseElseIf + , testCase "elseif chain " caseElseIfChain + , testCase "list" caseList + , testCase "list chain" caseListChain + , testCase "script not empty" caseScriptNotEmpty + , testCase "meta empty" caseMetaEmpty + , testCase "input empty" caseInputEmpty + , testCase "multiple classes" caseMultiClass + , testCase "attrib order" caseAttribOrder + , testCase "nothing" caseNothing + , testCase "nothing chain " caseNothingChain + , testCase "just" caseJust + , testCase "just chain " caseJustChain + , testCase "constructor" caseConstructor + , testCase "url + params" caseUrlParams + , testCase "escape" caseEscape + , testCase "empty statement list" caseEmptyStatementList + , testCase "attribute conditionals" caseAttribCond + , testCase "non-ascii" caseNonAscii + , testCase "maybe function" caseMaybeFunction + , testCase "trailing dollar sign" caseTrailingDollarSign + , testCase "non leading percent sign" caseNonLeadingPercent + , testCase "quoted attributes" caseQuotedAttribs + , testCase "spaced derefs" caseSpacedDerefs + , testCase "attrib vars" caseAttribVars + , testCase "strings and html" caseStringsAndHtml + , testCase "nesting" caseNesting + , testCase "trailing space" caseTrailingSpace + , testCase "currency symbols" caseCurrency + , testCase "external" caseExternal + ] + +data Url = Home | Sub SubUrl +data SubUrl = SubUrl +render :: Url -> String +render Home = "url" +render (Sub SubUrl) = "suburl" + +data Arg url = Arg + { getArg :: Arg url + , var :: Html () + , url :: Url + , embed :: Hamlet url + , true :: Bool + , false :: Bool + , list :: [Arg url] + , nothing :: Maybe String + , just :: Maybe String + , urlParams :: (Url, [(String, String)]) + } + +theArg :: Arg url +theArg = Arg + { getArg = theArg + , var = string "" + , url = Home + , embed = [$hamlet|embed|] + , true = True + , false = False + , list = [theArg, theArg, theArg] + , nothing = Nothing + , just = Just "just" + , urlParams = (Home, [("foo", "bar"), ("foo1", "bar1")]) + } + +helper :: String -> Hamlet Url -> Assertion +helper res h = do + let x = renderHamlet render h + res @=? toString x + +caseEmpty :: Assertion +caseEmpty = helper "" [$hamlet||] + +caseStatic :: Assertion +caseStatic = helper "some static content" [$hamlet|some static content|] + +caseTag :: Assertion +caseTag = helper "

baz

" [$hamlet| +%p.foo + #bar baz|] + +caseVar :: Assertion +caseVar = do + helper "<var>" [$hamlet|$var.theArg$|] + +caseVarChain :: Assertion +caseVarChain = do + helper "<var>" [$hamlet|$var.getArg.getArg.getArg.theArg$|] + +caseUrl :: Assertion +caseUrl = do + helper (render Home) [$hamlet|@url.theArg@|] + +caseUrlChain :: Assertion +caseUrlChain = do + helper (render Home) [$hamlet|@url.getArg.getArg.getArg.theArg@|] + +caseEmbed :: Assertion +caseEmbed = do + helper "embed" [$hamlet|^embed.theArg^|] + +caseEmbedChain :: Assertion +caseEmbedChain = do + helper "embed" [$hamlet|^embed.getArg.getArg.getArg.theArg^|] + +caseIf :: Assertion +caseIf = do + helper "if" [$hamlet| +$if true.theArg + if +|] + +caseIfChain :: Assertion +caseIfChain = do + helper "if" [$hamlet| +$if true.getArg.getArg.getArg.theArg + if +|] + +caseElse :: Assertion +caseElse = helper "else" [$hamlet| +$if false.theArg + if +$else + else +|] + +caseElseChain :: Assertion +caseElseChain = helper "else" [$hamlet| +$if false.getArg.getArg.getArg.theArg + if +$else + else +|] + +caseElseIf :: Assertion +caseElseIf = helper "elseif" [$hamlet| +$if false.theArg + if +$elseif true.theArg + elseif +$else + else +|] + +caseElseIfChain :: Assertion +caseElseIfChain = helper "elseif" [$hamlet| +$if false.getArg.getArg.getArg.theArg + if +$elseif true.getArg.getArg.getArg.theArg + elseif +$else + else +|] + +caseList :: Assertion +caseList = do + helper "xxx" [$hamlet| +$forall list.theArg _x + x +|] + +caseListChain :: Assertion +caseListChain = do + helper "urlurlurl" [$hamlet| +$forall list.getArg.getArg.getArg.getArg.getArg.theArg x + @url.x@ +|] + +caseScriptNotEmpty :: Assertion +caseScriptNotEmpty = helper "" [$hamlet|%script|] + +caseMetaEmpty :: Assertion +caseMetaEmpty = do + helper "" [$hamlet|%meta|] + helper "" [$xhamlet|%meta|] + +caseInputEmpty :: Assertion +caseInputEmpty = do + helper "" [$hamlet|%input|] + helper "" [$xhamlet|%input|] + +caseMultiClass :: Assertion +caseMultiClass = do + helper "
" [$hamlet|.foo.bar|] + +caseAttribOrder :: Assertion +caseAttribOrder = helper "" [$hamlet|%meta!1!2!3|] + +caseNothing :: Assertion +caseNothing = do + helper "" [$hamlet| +$maybe nothing.theArg _n + nothing +|] + helper "nothing" [$hamlet| +$maybe nothing.theArg _n + something +$nothing + nothing +|] + +caseNothingChain :: Assertion +caseNothingChain = helper "" [$hamlet| +$maybe nothing.getArg.getArg.getArg.theArg n + nothing $n$ +|] + +caseJust :: Assertion +caseJust = helper "it's just" [$hamlet| +$maybe just.theArg n + it's $n$ +|] + +caseJustChain :: Assertion +caseJustChain = helper "it's just" [$hamlet| +$maybe just.getArg.getArg.getArg.theArg n + it's $n$ +|] + +caseConstructor :: Assertion +caseConstructor = do + helper "url" [$hamlet|@Home@|] + helper "suburl" [$hamlet|@Sub.SubUrl@|] + let text = "" + helper "" [$hamlet|$preEscapedString.text$|] + +caseUrlParams :: Assertion +caseUrlParams = do + helper "url?foo=bar&foo1=bar1" [$hamlet|@?urlParams.theArg@|] + +caseEscape :: Assertion +caseEscape = do + helper "#this is raw\n " [$hamlet| +\#this is raw +\ +\ +|] + helper "$@^" [$hamlet|$$@@^^|] + +caseEmptyStatementList :: Assertion +caseEmptyStatementList = do + helper "" [$hamlet|$if True|] + helper "" [$hamlet|$maybe Nothing _x|] + let emptyList = [] + helper "" [$hamlet|$forall emptyList _x|] + +caseAttribCond :: Assertion +caseAttribCond = do + helper "" [$hamlet|%select!:False:selected|] + helper "" [$hamlet|%select!:True:selected|] + helper "" [$hamlet|%meta!var=foo:bar|] + helper "" + [$hamlet|%select!:true.theArg:selected|] + +caseNonAscii :: Assertion +caseNonAscii = do + helper "עִבְרִי" [$hamlet|עִבְרִי|] + +caseMaybeFunction :: Assertion +caseMaybeFunction = do + helper "url?foo=bar&foo1=bar1" [$hamlet| +$maybe Just.urlParams x + @?x.theArg@ +|] + +caseTrailingDollarSign :: Assertion +caseTrailingDollarSign = + helper "trailing space \ndollar sign $" [$hamlet|trailing space $ +\ +dollar sign $$|] + +caseNonLeadingPercent :: Assertion +caseNonLeadingPercent = + helper "foo" [$hamlet| +%span!style=height:100% foo +|] + +caseQuotedAttribs :: Assertion +caseQuotedAttribs = + helper "" [$hamlet| +%input!type=submit!value="Submit response" +|] + +caseSpacedDerefs :: Assertion +caseSpacedDerefs = do + helper "<var>" [$hamlet|$var theArg$|] + helper "
" [$hamlet|.$var theArg$|] + +caseAttribVars :: Assertion +caseAttribVars = do + helper "
" [$hamlet|#$var.theArg$|] + helper "
" [$hamlet|.$var.theArg$|] + helper "
" [$hamlet|%div!f=$var.theArg$|] + +caseStringsAndHtml :: Assertion +caseStringsAndHtml = do + let str = "" + let html = preEscapedString "" + helper "<string> " [$hamlet|$str$ $html$|] + +caseNesting :: Assertion +caseNesting = do + helper + "
1
2
" + [$hamlet| +%table + %tbody + $forall users user + %tr + %td $user$ +|] + helper + (concat + [ "" + ]) + [$hamlet| +%select#$name$!name=$name$ + %option!:isBoolBlank.val:selected + %option!value=true!:isBoolTrue.val:selected Yes + %option!value=false!:isBoolFalse.val:selected No +|] + where + users = ["1", "2"] + name = "foo" + val = 5 + isBoolBlank _ = True + isBoolTrue _ = False + isBoolFalse _ = False + +caseTrailingSpace :: Assertion +caseTrailingSpace = + helper "" [$hamlet| |] + +caseCurrency :: Assertion +caseCurrency = + helper foo [$hamlet|$foo$|] + where + foo = "eg: 5, $6, €7.01, £75" + +caseExternal :: Assertion +caseExternal = do + helper "foo
" $ $(hamletFile "external.hamlet") + helper "foo
" $ $(xhamletFile "external.hamlet") + where + foo = "foo"