{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
import Test.Framework (defaultMain, testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test)
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Data.List (intercalate)
import Text.Utf8
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
, testCase "parens" caseParens
, testCase "hamlet literals"caseHamletLiterals
, testCase "hamlet' and xhamlet'" caseHamlet'
, testCase "hamletDebug" caseHamletDebug
, testCase "hamlet runtime" caseHamletRT
, testCase "hamletFileDebug- changing file" caseHamletFileDebugChange
, testCase "hamletFileDebug- features" caseHamletFileDebugFeatures
, testCase "cassius" caseCassius
, testCase "cassiusFile" caseCassiusFile
, testCase "cassiusFileDebug" caseCassiusFileDebug
, testCase "cassiusFileDebugChange" caseCassiusFileDebugChange
, testCase "julius" caseJulius
, testCase "juliusFile" caseJuliusFile
, testCase "juliusFileDebug" caseJuliusFileDebug
, testCase "juliusFileDebugChange" caseJuliusFileDebugChange
, testCase "comments" caseComments
, testCase "hamletFileDebug double foralls" caseDoubleForalls
, testCase "cassius pseudo-class" casePseudo
, testCase "different binding names" caseDiffBindNames
, testCase "blank line" caseBlankLine
, testCase "leading spaces" caseLeadingSpaces
, testCase "cassius all spaces" caseCassiusAllSpaces
, testCase "cassius whitespace and colons" caseCassiusWhitespaceColons
, testCase "cassius trailing comments" caseCassiusTrailingComments
]
data Url = Home | Sub SubUrl
data SubUrl = SubUrl
render :: Url -> [(String, String)] -> String
render Home qs = "url" ++ showParams qs
render (Sub SubUrl) qs = "suburl" ++ showParams qs
showParams :: [(String, String)] -> String
showParams [] = ""
showParams z =
'?' : intercalate "&" (map go z)
where
go (x, y) = go' x ++ '=' : go' y
go' = concatMap encodeUrlChar
-- | Taken straight from web-encodings; reimplemented here to avoid extra
-- dependencies.
encodeUrlChar :: Char -> String
encodeUrlChar c
-- List of unreserved characters per RFC 3986
-- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding
| 'A' <= c && c <= 'Z' = [c]
| 'a' <= c && c <= 'z' = [c]
| '0' <= c && c <= '9' = [c]
encodeUrlChar c@'-' = [c]
encodeUrlChar c@'_' = [c]
encodeUrlChar c@'.' = [c]
encodeUrlChar c@'~' = [c]
encodeUrlChar ' ' = "+"
encodeUrlChar y =
let (a, c) = fromEnum y `divMod` 16
b = a `mod` 16
showHex' x
| x < 10 = toEnum $ x + (fromEnum '0')
| x < 16 = toEnum $ x - 10 + (fromEnum 'A')
| otherwise = error $ "Invalid argument to showHex: " ++ show x
in ['%', showHex' b, showHex' c]
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 @=? lbsToChars x
caseEmpty :: Assertion
caseEmpty = helper "" [$hamlet||]
caseStatic :: Assertion
caseStatic = helper "some static content" [$hamlet|some static content|]
caseTag :: Assertion
caseTag = helper "
1 |
2 |
foo
\nbar
\n" [$hamletDebug| %p foo %p bar |] caseHamletRT :: Assertion caseHamletRT = do temp <- parseHamletRT defaultHamletSettings "$var$" rt <- parseHamletRT defaultHamletSettings $ unlines [ "$baz.bar.foo$ bin $" , "$forall list l" , " $l$" , "$maybe just j" , " $j$" , "$maybe nothing n" , "$nothing" , " nothing" , "^template^" , "@url@" , "$if false" , "$elseif false" , "$elseif true" , " a" , "$if false" , "$else" , " b" , "@?urlp@" ] let scope = [ (["foo", "bar", "baz"], HDHtml $ preEscapedString "foofoo
" [$hamlet| %p foo |] celper "foo{bar:baz}" [$cassius| foo bar: baz |] caseLeadingSpaces :: Assertion caseLeadingSpaces = celper "foo{bar:baz}" [$cassius| foo bar: baz |] caseTrailingSpaces :: Assertion caseTrailingSpaces = helper "" [$hamlet| $if True $elseif False $else $maybe Nothing x $nothing $forall empty x |] where empty = [] caseCassiusAllSpaces :: Assertion caseCassiusAllSpaces = do celper "h1{color:green }" [$cassius| h1 color: green |] caseCassiusWhitespaceColons :: Assertion caseCassiusWhitespaceColons = do celper "h1:hover{color:green ;font-family:sans-serif}" [$cassius| h1:hover color: green font-family:sans-serif |] caseCassiusTrailingComments :: Assertion caseCassiusTrailingComments = do celper "h1:hover {color:green ;font-family:sans-serif}" [$cassius| h1:hover $# Please ignore this color: green $# This is a comment. $# Obviously this is ignored too. font-family:sans-serif |]