shakespeare 2.0.9 → 2.0.10
raw patch · 11 files changed
+1894/−1887 lines, 11 files
Files
- ChangeLog.md +4/−0
- Text/Hamlet.hs +6/−0
- shakespeare.cabal +4/−4
- test/Text/CssSpec.hs +611/−0
- test/Text/HamletSpec.hs +1066/−0
- test/Text/JuliusSpec.hs +202/−0
- test/Text/Shakespeare/BaseSpec.hs +1/−1
- test/Text/Shakespeare/CssSpec.hs +0/−612
- test/Text/Shakespeare/HamletSpec.hs +0/−1067
- test/Text/Shakespeare/JsSpec.hs +0/−202
- test/Text/Shakespeare/TextSpec.hs +0/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+### 2.0.10++* Added `ixhamlet` [#177](https://github.com/yesodweb/shakespeare/pull/177)+ ### 2.0.9 * Better empty HTML tag list
Text/Hamlet.hs view
@@ -385,6 +385,12 @@ urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur') em _ _ = error "bad Env" +-- | Quasiquoter that follows XHTML serialization rules and supports i18n.+--+-- @since 2.0.10+ixhamlet :: QuasiQuoter+ixhamlet = hamletWithSettings ihamletRules xhtmlHamletSettings+ hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter hamletWithSettings hr set = QuasiQuoter
shakespeare.cabal view
@@ -1,5 +1,5 @@ name: shakespeare-version: 2.0.9+version: 2.0.10 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -111,10 +111,10 @@ main-is: Spec.hs other-modules: Text.Shakespeare.BaseSpec Text.Shakespeare.I18NSpec- Text.Shakespeare.JsSpec Text.Shakespeare.TextSpec- Text.Shakespeare.CssSpec- Text.Shakespeare.HamletSpec+ Text.CssSpec+ Text.HamletSpec+ Text.JuliusSpec Quoter HamletTestTypes
+ test/Text/CssSpec.hs view
@@ -0,0 +1,611 @@+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -O0 #-} +module Text.CssSpec (spec) where + +import Test.HUnit hiding (Test) +import Test.Hspec + +import Prelude hiding (reverse) +import Text.Cassius +import Text.Lucius +import Data.List (intercalate) +import qualified Data.Text.Lazy as T +import qualified Data.Text as TS +import qualified Data.List +import qualified Data.List as L +import Data.Text (Text, pack, unpack) +import Data.Monoid (mappend) + +spec :: Spec +spec = do + it "cassius" caseCassius + it "cassiusFile" caseCassiusFile + it "cassius single comment" caseCassiusSingleComment + it "cassius leading comment" caseCassiusLeadingComment + + it "cassiusFileDebug" $ do + let var = "var" + let selector = "foo" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper $(cassiusFileDebug "test/cassiuses/external1.cassius") $ concat + [ "foo {\n background: #000;\n bar: baz;\n color: #F00;\n}\n" + , "bin {\n" + , " background-image: url(url);\n" + , " bar: bar;\n color: #7F6405;\n fvarx: someval;\n unicode-test: שלום;\n" + , " urlp: url(url?p=q);\n}\n" + ] + +{- TODO + it "cassiusFileDebugChange" $ do + let var = "var" + writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" + celper "foo{var:1}" $(cassiusFileDebug "test/cassiuses/external2.cassius") + writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 2" + celper "foo{var:2}" $(cassiusFileDebug "test/cassiuses/external2.cassius") + writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" + -} + + + it "comments" $ do + -- FIXME reconsider Hamlet comment syntax? + celper "" [cassius|/* this is a comment */ +/* another comment */ +/*a third one*/|] + + + it "cassius pseudo-class" $ + flip celper [cassius| +a:visited + color: blue +|] "a:visited{color:blue}" + + + it "ignores a blank line" $ do + celper "foo{bar:baz}" [cassius| +foo + + bar: baz + +|] + + + it "leading spaces" $ + celper "foo{bar:baz}" [cassius| + foo + bar: baz +|] + + + it "cassius all spaces" $ + celper "h1{color:green }" [cassius| + h1 + color: green + |] + + + it "cassius whitespace and colons" $ do + celper "h1:hover{color:green ;font-family:sans-serif}" [cassius| + h1:hover + color: green + font-family:sans-serif + |] + + + it "cassius trailing comments" $ + 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 + |] + + it "cassius nesting" $ + celper "foo bar{baz:bin}" [cassius| + foo + bar + baz: bin + |] + + it "cassius variable" $ + celper "foo bar{baz:bin}" [cassius| + @binvar: bin + foo + bar + baz: #{binvar} + |] + + it "cassius trailing semicolon" $ + celper "foo bar{baz:bin}" [cassius| + @binvar: bin + foo + bar + baz: #{binvar}; + |] + + + + it "cassius module names" $ do + let foo = "foo" + dub = 3.14::Double + int = -5::Int + celper "sel{bar:oof oof 3.14 -5}" + [cassius| +sel + bar: #{Data.List.reverse foo} #{L.reverse foo} #{show dub} #{show int} +|] + + + + it "single dollar at and caret" $ do + celper "sel{att:$@^}" [cassius| +sel + att: $@^ +|] + + {- + celper "sel{att:#{@{^{}" [cassius| +sel + att: #\{@\{^{ +|] +-} + + + it "dollar operator" $ do + let val = (1, (2, 3)) :: (Integer, (Integer, Integer)) + celper "sel{att:2}" [cassius| +sel + att: #{ show $ fst $ snd val } +|] + celper "sel{att:2}" [cassius| +sel + att: #{ show $ fst $ snd $ val} +|] + + + + it "embedded slash" $ do + celper "sel{att:///}" [cassius| +sel + att: /// +|] + + + + + + + it "multi cassius" $ do + celper "foo{bar:baz;bar:bin}" [cassius| +foo + bar: baz + bar: bin +|] + + + + + + + it "lucius" $ do + let var = "var" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper [lucius| +foo { + background: #{colorBlack}; + bar: baz; + color: #{colorRed}; +} +bin { + background-image: url(@{Home}); + bar: bar; + color: #{(((Color 127) 100) 5)}; + f#{var}x: someval; + unicode-test: שלום; + urlp: url(@?{urlp}); +} +|] $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + + + + it "lucius file" $ do + let var = "var" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper $(luciusFile "test/cassiuses/external1.lucius") $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + + it "lucius file debug" caseLuciusFileDebug + + + + + it "lucius nested" $ do + celper "foo bar{baz:bin}" $(luciusFile "test/cassiuses/external-nested.lucius") + celper "foo bar {\n baz: bin;\n}\n" $(luciusFileDebug "test/cassiuses/external-nested.lucius") + celper "foo bar{baz:bin}" [lucius| + foo { + bar { + baz: bin; + } + } + |] + celper "foo1 bar,foo2 bar{baz:bin}" [lucius| + foo1, foo2 { + bar { + baz: bin; + } + } + |] + + + it "lucius charset" $ do + celper (concat ["@charset \"utf-8\";" + , "#content ul{list-style:none;padding:0 5em}" + , "#content ul li{padding:1em 0}" + , "#content ul li a{color:#419a56;font-family:'TeXGyreHerosBold',helvetica,arial,sans-serif;font-weight:bold;text-transform:uppercase;white-space:nowrap}" + ]) [lucius| +@charset "utf-8"; +#content ul +{ + list-style: none; + padding: 0 5em; + li + { + padding: 1em 0; + a + { + color: #419a56; + font-family: 'TeXGyreHerosBold',helvetica,arial,sans-serif; + font-weight: bold; + text-transform: uppercase; + white-space: nowrap; + } + } +} +|] + + it "lucius media" $ do + celper "@media only screen{foo bar{baz:bin}}" $(luciusFile "test/cassiuses/external-media.lucius") + celper "@media only screen {\n foo bar {\n baz: bin;\n }\n}\n" $(luciusFileDebug "test/cassiuses/external-media.lucius") + celper "@media only screen{foo bar{baz:bin}}" [lucius| + @media only screen{ + foo { + bar { + baz: bin; + } + } + } + |] + + + {- + it "cassius removes whitespace" $ do + celper "foo{bar:baz}" [cassius| + foo + bar : baz + |] + -} + + + + + + it "lucius trailing comments" $ + celper "foo{bar:baz}" [lucius|foo{bar:baz;}/* ignored*/|] + + it "lucius variables" $ celper "foo{bar:baz}" [lucius| +@myvar: baz; +foo { + bar: #{myvar}; +} +|] + it "lucius CDO/CDC tokens" $ + celper "*{a:b}" [lucius| +<!-- --> <!-- +* { + a: b; +} +--> +|] + it "lucius @import statements" $ + celper "@import url(\"bla.css\");" [lucius| +@import url("bla.css"); +|] + it "lucius simple escapes" $ + celper "*{a:test}" [lucius| +* { + a: t\65 st; +} +|] + it "lucius bounded escapes" $ + celper "*{a:teft}" [lucius| +* { + a: t\000065ft; +} +|] + it "lucius case-insensitive keywords" $ + celper "@media foo {}" [lucius| +@MeDIa foo { +} +|] + it "lucius @page statements" $ + celper "@page :right{a:b;c:d}" [lucius| +@page :right { +a:b; +c:d; +} +|] + it "lucius @font-face statements" $ + celper "@font-face{a:b;c:d}" [lucius| +@font-face { +a:b; +c:d; +} +|] + it "lucius runtime" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "foo { bar: #{myvar}}") [(TS.pack "myvar", TS.pack "baz")] + it "lucius runtime variables" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "@dummy: dummy; @myvar: baz; @dummy2: dummy; foo { bar: #{myvar}}") [] + it "lucius whtiespace" $ Right (T.pack "@media foo {\n bar {\n baz: bin;\n baz2: bin2;\n }\n}\n") + @=? luciusRT (T.pack "@media foo{bar{baz:bin;baz2:bin2}}") [] + it "variables inside value" $ + celper "foo{foo:XbarY}" [lucius| +@bar: bar; +foo { foo:X#{bar}Y; } +|] + it "variables in media selector" $ + celper "@media (max-width: 400px){foo{color:red}}" [lucius| +@mobileWidth: 400px; +@media (max-width: #{mobileWidth}){ foo { color: red; } } +|] + it "URLs in import" $ celper + "@import url(\"suburl\");" [lucius| +@import url("@{Sub SubUrl}"); +|] + it "vars in charset" $ do + let charset = "mycharset" + celper "@charset mycharset;" [lucius| +@charset #{charset}; +|] + it "keyframes" $ celper + "@keyframes mymove {from{top:0px}to{top:200px}}" [lucius| +@keyframes mymove { + from { + top: 0px; + } + to { + top: 200px; + } +} +|] + it "prefixed keyframes" $ celper + "@-webkit-keyframes mymove {from{top:0px}to{top:200px}}" [lucius| +@-webkit-keyframes mymove { + from { + top: 0px; + } + to { + top: 200px; + } +} +|] + it "lucius mixins" $ do + let bins = [luciusMixin| + bin:bin2; + /* FIXME not currently implementing sublocks in mixins + foo2 { + x: y + } + */ + |] :: Mixin + -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| + celper "foo{bar:baz;bin:bin2}" [lucius| + foo { + bar: baz; + ^{bins} + } + |] + it "cassius mixins" $ do + let bins = [cassiusMixin| + bin:bin2 + bin3:bin4 + |] :: Mixin + -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| + celper "foo{bar:baz;bin:bin2;bin3:bin4}" [lucius| + foo { + bar: baz; + ^{bins} + } + |] + it "more complicated mixins" $ do + let transition val = + [luciusMixin| + -webkit-transition: #{val}; + -moz-transition: #{val}; + -ms-transition: #{val}; + -o-transition: #{val}; + transition: #{val}; + |] + + celper ".some-class{-webkit-transition:all 4s ease;-moz-transition:all 4s ease;-ms-transition:all 4s ease;-o-transition:all 4s ease;transition:all 4s ease}" + [lucius| + .some-class { + ^{transition "all 4s ease"} + } + |] + + it "runtime mixin" $ do + let bins = [luciusMixin| + bin:bin2; + /* FIXME not currently implementing sublocks in mixins + foo2 { + x: y + } + */ + |] :: Mixin + -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| + Right (T.pack "foo{bar:baz;bin:bin2}") @=? luciusRTMixin + (T.pack "foo { bar: baz; ^{bins} }") + True + [(TS.pack "bins", RTVMixin bins)] + + it "luciusFileReload mixin" $ do + let mixin = [luciusMixin|foo:bar;baz:bin|] + flip celper $(luciusFileReload "test/cassiuses/mixin.lucius") $ concat + [ "selector {\n foo: bar;\n baz: bin;\n}\n" + ] + + it "cassiusFileReload with import URL" $ do + celper + "@import url(url);\n" + $(cassiusFileReload "test/cassiuses/reload-import.cassius") + + it "& subblocks" $ + celper "foo:bar{baz:bin}" + [lucius| + foo { + &:bar { + baz: bin; + } + } + |] + + describe "font-face #139" $ do + it "lucius" $ + celper "@font-face{font-family:myFirstFont;src:url(sansation_light.woff)}" + [lucius| + @font-face { + font-family: myFirstFont; + src: url(sansation_light.woff); + } + |] + it "cassius" $ + celper "@font-face{font-family:myFirstFont;src:url(sansation_light.woff)}" + [cassius| + @font-face + font-family: myFirstFont + src: url(sansation_light.woff) + |] + +data Url = Home | Sub SubUrl +data SubUrl = SubUrl +render :: Url -> [(Text, Text)] -> Text +render Home qs = pack "url" `mappend` showParams qs +render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs + +showParams :: [(Text, Text)] -> Text +showParams [] = pack "" +showParams z = + pack $ '?' : intercalate "&" (map go z) + where + go (x, y) = go' x ++ '=' : go' y + go' = concatMap encodeUrlChar . unpack + +-- | 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] + + + +celper :: String -> CssUrl Url -> Assertion +celper res h = do + let x = renderCssUrl render h + T.pack res @=? x + +caseCassius :: Assertion +caseCassius = do + let var = "var" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper [cassius| +foo + background: #{colorBlack} + bar: baz + color: #{colorRed} +bin + background-image: url(@{Home}) + bar: bar + color: #{(((Color 127) 100) 5)} + f#{var}x: someval + unicode-test: שלום + urlp: url(@?{urlp}) +|] $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + +caseCassiusFile :: Assertion +caseCassiusFile = do + let var = "var" + let selector = "foo" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper $(cassiusFile "test/cassiuses/external1.cassius") $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + +caseCassiusSingleComment :: Assertion +caseCassiusSingleComment = + flip celper [cassius| + /* + this is a comment + */ + |] "" + +caseCassiusLeadingComment :: Assertion +caseCassiusLeadingComment = + flip celper [cassius| + /* + this is a comment + */ + sel1 + foo: bar + sel2 + baz: bin + |] "sel1{foo:bar}sel2{baz:bin}" + +instance Show Url where + show _ = "FIXME remove this instance show Url" + + +caseLuciusFileDebug :: Assertion +caseLuciusFileDebug = do + let var = "var" + writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}" + celper "foo {\n var: 1;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") + writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 2}" + celper "foo {\n var: 2;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") + writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}"
+ test/Text/HamletSpec.hs view
@@ -0,0 +1,1066 @@+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +module Text.HamletSpec (spec) where + +import HamletTestTypes (ARecord(..)) + +import Test.HUnit hiding (Test) +import Test.Hspec hiding (Arg) + +import Prelude hiding (reverse) +import Text.Hamlet +import Text.Hamlet.RT +import Data.List (intercalate) +import qualified Data.Text.Lazy as T +import qualified Data.List +import qualified Data.List as L +import Data.Text (Text, pack, unpack) +import Data.Monoid (mappend) +import qualified Data.Set as Set +import qualified Text.Blaze.Html.Renderer.Text +import Text.Blaze.Html (toHtml) +import Text.Blaze.Internal (preEscapedString) +import Text.Blaze + +spec = do + it "empty" caseEmpty + it "static" caseStatic + it "tag" caseTag + it "var" caseVar + it "var chain " caseVarChain + it "url" caseUrl + it "url chain " caseUrlChain + it "embed" caseEmbed + it "embed chain " caseEmbedChain + it "if" caseIf + it "if chain " caseIfChain + it "else" caseElse + it "else chain " caseElseChain + it "elseif" caseElseIf + it "elseif chain " caseElseIfChain + it "list" caseList + it "list chain" caseListChain + it "with" caseWith + it "with multi" caseWithMulti + it "with chain" caseWithChain + it "with comma string" caseWithCommaString + it "with multi scope" caseWithMultiBindingScope + it "script not empty" caseScriptNotEmpty + it "meta empty" caseMetaEmpty + it "input empty" caseInputEmpty + it "multiple classes" caseMultiClass + it "attrib order" caseAttribOrder + it "nothing" caseNothing + it "nothing chain " caseNothingChain + it "just" caseJust + it "just chain " caseJustChain + it "constructor" caseConstructor + it "url + params" caseUrlParams + it "escape" caseEscape + it "empty statement list" caseEmptyStatementList + it "attribute conditionals" caseAttribCond + it "non-ascii" caseNonAscii + it "maybe function" caseMaybeFunction + it "trailing dollar sign" caseTrailingDollarSign + it "non leading percent sign" caseNonLeadingPercent + it "quoted attributes" caseQuotedAttribs + it "spaced derefs" caseSpacedDerefs + it "attrib vars" caseAttribVars + it "strings and html" caseStringsAndHtml + it "nesting" caseNesting + it "trailing space" caseTrailingSpace + it "currency symbols" caseCurrency + it "external" caseExternal + it "parens" caseParens + it "hamlet literals" caseHamletLiterals + it "hamlet' and xhamlet'" caseHamlet' + it "hamlet tuple" caseTuple + it "complex pattern" caseComplex + it "record pattern" caseRecord + it "record wildcard pattern #1" caseRecordWildCard + it "record wildcard pattern #2" caseRecordWildCard1 + + + + it "comments" $ do + -- FIXME reconsider Hamlet comment syntax? + helper "" [hamlet|$# this is a comment +$# another comment +$#a third one|] + + + it "ignores a blank line" $ do + helper "<p>foo</p>\n" [hamlet| +<p> + + foo + + +|] + + + + + it "angle bracket syntax" $ + helper "<p class=\"foo\" height=\"100\"><span id=\"bar\" width=\"50\">HELLO</span></p>" + [hamlet| +$newline never +<p.foo height="100"> + <span #bar width=50>HELLO +|] + + + + it "hamlet module names" $ do + let foo = "foo" + helper "oof oof 3.14 -5" + [hamlet| +$newline never +#{Data.List.reverse foo} # +#{L.reverse foo} # +#{show 3.14} #{show -5}|] + + + + + + it "single dollar at and caret" $ do + helper "$@^" [hamlet|\$@^|] + + helper "#{@{^{" [hamlet|#\{@\{^\{|] + + + it "dollar operator" $ do + let val = (1, (2, 3)) + helper "2" [hamlet|#{ show $ fst $ snd val }|] + helper "2" [hamlet|#{ show $ fst $ snd $ val}|] + + + it "in a row" $ do + helper "1" [hamlet|#{ show $ const 1 2 }|] + + + it "embedded slash" $ do + helper "///" [hamlet|///|] + +{- compile-time error + it "tag with slash" $ do + helper "" [hamlet| +<p> + Text +</p> +|] +-} + + it "string literals" $ do + helper "string" [hamlet|#{"string"}|] + helper "string" [hamlet|#{id "string"}|] + helper "gnirts" [hamlet|#{L.reverse $ id "string"}|] + helper "str"ing" [hamlet|#{"str\"ing"}|] + helper "str<ing" [hamlet|#{"str<ing"}|] + + + it "interpolated operators" $ do + helper "3" [hamlet|#{show $ (+) 1 2}|] + helper "6" [hamlet|#{show $ sum $ (:) 1 ((:) 2 $ return 3)}|] + + + it "HTML comments" $ do + helper "<p>1</p><p>2 not ignored</p>" [hamlet| +$newline never +<p>1 +<!-- ignored comment --> +<p> + 2 + <!-- ignored --> not ignored<!-- ignored --> +|] + + it "Keeps SSI includes" $ + helper "<!--# SSI -->" [hamlet|<!--# SSI -->|] + + + + it "nested maybes" $ do + let muser = Just "User" :: Maybe String + mprof = Nothing :: Maybe Int + m3 = Nothing :: Maybe String + helper "justnothing" [hamlet| +$maybe user <- muser + $maybe profile <- mprof + First two are Just + $maybe desc <- m3 + \ and left us a description: + <p>#{desc} + $nothing + and has left us no description. + $nothing + justnothing +$nothing + <h1>No such Person exists. + |] + + + it "maybe with qualified constructor" $ do + helper "5" [hamlet| + $maybe HamletTestTypes.ARecord x y <- Just $ ARecord 5 True + \#{x} + |] + + it "record with qualified constructor" $ do + helper "5" [hamlet| + $maybe HamletTestTypes.ARecord {..} <- Just $ ARecord 5 True + \#{field1} + |] + + + + + it "conditional class" $ do + helper "<p class=\"current\"></p>\n" + [hamlet|<p :False:.ignored :True:.current>|] + + helper "<p class=\"1 3 2 4\"></p>\n" + [hamlet|<p :True:.1 :True:class=2 :False:.a :False:class=b .3 class=4>|] + + helper "<p class=\"foo bar baz\"></p>\n" + [hamlet|<p class=foo class=bar class=baz>|] + + + + + it "forall on Foldable" $ do + let set = Set.fromList [1..5 :: Int] + helper "12345" [hamlet| +$forall x <- set + #{x} +|] + + + + it "non-poly HTML" $ do + helperHtml "<h1>HELLO WORLD</h1>\n" [shamlet| + <h1>HELLO WORLD + |] + helperHtml "<h1>HELLO WORLD</h1>\n" $(shamletFile "test/hamlets/nonpolyhtml.hamlet") + helper "<h1>HELLO WORLD</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhtml.hamlet") + + + it "non-poly Hamlet" $ do + let embed = [hamlet|<p>EMBEDDED|] + helper "<h1>url</h1>\n<p>EMBEDDED</p>\n" [hamlet| + <h1>@{Home} + ^{embed} + |] + helper "<h1>url</h1>\n" $(hamletFile "test/hamlets/nonpolyhamlet.hamlet") + helper "<h1>url</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhamlet.hamlet") + + it "non-poly IHamlet" $ do + let embed = [ihamlet|<p>EMBEDDED|] + ihelper "<h1>Adios</h1>\n<p>EMBEDDED</p>\n" [ihamlet| + <h1>_{Goodbye} + ^{embed} + |] + ihelper "<h1>Hola</h1>\n" $(ihamletFile "test/hamlets/nonpolyihamlet.hamlet") + ihelper "<h1>Hola</h1>\n" $(ihamletFileReload "test/hamlets/nonpolyihamlet.hamlet") + + it "pattern-match tuples: forall" $ do + let people = [("Michael", 26), ("Miriam", 25)] + helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet| +$newline never +<dl> + $forall (name, age) <- people + <dt>#{name} + <dd>#{show age} +|] + it "pattern-match tuples: maybe" $ do + let people = Just ("Michael", 26) + helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| +$newline never +<dl> + $maybe (name, age) <- people + <dt>#{name} + <dd>#{show age} +|] + it "pattern-match tuples: with" $ do + let people = ("Michael", 26) + helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| +$newline never +<dl> + $with (name, age) <- people + <dt>#{name} + <dd>#{show age} +|] + it "list syntax for interpolation" $ do + helper "<ul><li>1</li><li>2</li><li>3</li></ul>" [hamlet| +$newline never +<ul> + $forall num <- [1, 2, 3] + <li>#{show num} +|] + it "infix operators" $ + helper "5" [hamlet|#{show $ (4 + 5) - (2 + 2)}|] + it "infix operators with parens" $ + helper "5" [hamlet|#{show ((+) 1 1 + 3)}|] + it "doctypes" $ helper "<!DOCTYPE html>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" [hamlet| +$newline never +$doctype 5 +$doctype strict +|] + + it "case on Maybe" $ + let nothing = Nothing + justTrue = Just True + in helper "<br><br><br><br>" [hamlet| +$newline never +$case nothing + $of Just val + $of Nothing + <br> +$case justTrue + $of Just val + $if val + <br> + $of Nothing +$case (Just $ not False) + $of Nothing + $of Just val + $if val + <br> +$case Nothing + $of Just val + $of _ + <br> +|] + + it "case on Url" $ + let url1 = Home + url2 = Sub SubUrl + in helper "<br>\n<br>\n" [hamlet| +$newline always +$case url1 + $of Home + <br> + $of _ +$case url2 + $of Sub sub + $case sub + $of SubUrl + <br> + $of Home +|] + + it "pattern-match constructors: forall" $ do + let people = [Pair "Michael" 26, Pair "Miriam" 25] + helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet| +$newline text +<dl> + $forall Pair name age <- people + <dt>#{name} + <dd>#{show age} +|] + it "pattern-match constructors: maybe" $ do + let people = Just $ Pair "Michael" 26 + helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| +$newline text +<dl> + $maybe Pair name age <- people + <dt>#{name} + <dd>#{show age} +|] + it "pattern-match constructors: with" $ do + let people = Pair "Michael" 26 + helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| +$newline text +<dl> + $with Pair name age <- people + <dt>#{name} + <dd>#{show age} +|] + + it "multiline tags" $ helper + "<foo bar=\"baz\" bin=\"bin\">content</foo>\n" [hamlet| +<foo bar=baz + bin=bin>content +|] + it "*{...} attributes" $ + let attrs = [("bar", "baz"), ("bin", "<>\"&")] in helper + "<foo bar=\"baz\" bin=\"<>"&\">content</foo>\n" [hamlet| +<foo *{attrs}>content +|] + it "blank attr values" $ helper + "<foo bar=\"\" baz bin=\"\"></foo>\n" + [hamlet|<foo bar="" baz bin=>|] + it "greater than in attr" $ helper + "<button data-bind=\"enable: someFunction() > 5\">hello</button>\n" + [hamlet|<button data-bind="enable: someFunction() > 5">hello|] + it "normal doctype" $ helper + "<!DOCTYPE html>\n" + [hamlet|<!DOCTYPE html>|] + it "newline style" $ helper + "<p>foo</p>\n<pre>bar\nbaz\nbin</pre>\n" + [hamlet| +$newline always +<p>foo +<pre> + bar + baz + bin +|] + it "avoid newlines" $ helper + "<p>foo</p><pre>barbazbin</pre>" + [hamlet| +$newline always +<p>foo# +<pre># + bar# + baz# + bin# +|] + it "manual linebreaks" $ helper + "<p>foo</p><pre>bar\nbaz\nbin</pre>" + [hamlet| +$newline never +<p>foo +<pre> + bar + \ + baz + \ + bin +|] + it "indented newline" $ helper + "<p>foo</p><pre>bar\nbaz\nbin</pre>" + [hamlet| + $newline never + <p>foo + <pre> + bar + \ + baz + \ + bin +|] + it "case underscore" $ + let num = 3 + in helper "<p>Many</p>\n" [hamlet| +$case num + $of 1 + <p>1 + $of 2 + <p>2 + $of _ + <p>Many +|] + it "optional and missing classes" $ + helper "<i>foo</i>\n" [hamlet|<i :False:.not-present>foo|] + it "multiple optional and missing classes" $ + helper "<i>foo</i>\n" [hamlet|<i :False:.not-present :False:.also-not-here>foo|] + it "optional and present classes" $ + helper "<i class=\"present\">foo</i>\n" [hamlet|<i :False:.not-present :True:.present>foo|] + it "punctuation operators #115" $ + helper "foo" + [hamlet| + $if True && True + foo + $else + bar + |] + + it "list syntax" $ + helper "123" + [hamlet| + $forall x <- [] + ignored + $forall x <- [1, 2, 3] + #{show x} + |] + + it "list in attribute" $ + let myShow :: [Int] -> String + myShow = show + in helper "<a href=\"[]\">foo</a>\n<a href=\"[1,2]\">bar</a>\n" + [hamlet| + <a href=#{myShow []}>foo + <a href=#{myShow [1, 2]}>bar + |] + + it "AngularJS attribute values #122" $ + helper "<li ng-repeat=\"addr in msgForm.new.split(/\\\\s/)\">{{addr}}</li>\n" + [hamlet|<li ng-repeat="addr in msgForm.new.split(/\\s/)">{{addr}}|] + + it "runtime Hamlet with caret interpolation" $ do + let toInclude render = render (5, [("hello", "world")]) + let renderer x y = pack $ show (x :: Int, y :: [(Text, Text)]) + template1 = "@?{url}" + template2 = "foo^{toInclude}bar" + toInclude <- parseHamletRT defaultHamletSettings template1 + hamletRT <- parseHamletRT defaultHamletSettings template2 + res <- renderHamletRT hamletRT + [ (["toInclude"], HDTemplate toInclude) + , (["url"], HDUrlParams 5 [(pack "hello", pack "world")]) + ] renderer + helperHtml "foo(5,[(\"hello\",\"world\")])bar" res + +data Pair = Pair String Int + +data Url = Home | Sub SubUrl +data SubUrl = SubUrl +render :: Url -> [(Text, Text)] -> Text +render Home qs = pack "url" `mappend` showParams qs +render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs + +showParams :: [(Text, Text)] -> Text +showParams [] = pack "" +showParams z = + pack $ '?' : intercalate "&" (map go z) + where + go (x, y) = go' x ++ '=' : go' y + go' = concatMap encodeUrlChar . unpack + +-- | 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 :: HtmlUrl url + , true :: Bool + , false :: Bool + , list :: [Arg url] + , nothing :: Maybe String + , just :: Maybe String + , urlParams :: (Url, [(Text, Text)]) + } + +theArg :: Arg url +theArg = Arg + { getArg = theArg + , var = toHtml "<var>" + , url = Home + , embed = [hamlet|embed|] + , true = True + , false = False + , list = [theArg, theArg, theArg] + , nothing = Nothing + , just = Just "just" + , urlParams = (Home, [(pack "foo", pack "bar"), (pack "foo1", pack "bar1")]) + } + +helperHtml :: String -> Html -> Assertion +helperHtml res h = do + let x = Text.Blaze.Html.Renderer.Text.renderHtml h + T.pack res @=? x + +helper :: String -> HtmlUrl Url -> Assertion +helper res h = do + let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h render + T.pack res @=? x + +caseEmpty :: Assertion +caseEmpty = helper "" [hamlet||] + +caseStatic :: Assertion +caseStatic = helper "some static content" [hamlet|some static content|] + +caseTag :: Assertion +caseTag = do + helper "<p class=\"foo\"><div id=\"bar\">baz</div></p>" [hamlet| +$newline text +<p .foo> + <#bar>baz +|] + helper "<p class=\"foo.bar\"><div id=\"bar\">baz</div></p>" [hamlet| +$newline text +<p class=foo.bar> + <#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 (unpack $ render Home []) [hamlet|@{url theArg}|] + +caseUrlChain :: Assertion +caseUrlChain = do + helper (unpack $ render Home []) [hamlet|@{url (getArg (getArg (getArg theArg)))}|] + +caseEmbed :: Assertion +caseEmbed = do + helper "embed" [hamlet|^{embed theArg}|] + helper "embed" $(hamletFileReload "test/hamlets/embed.hamlet") + ihelper "embed" $(ihamletFileReload "test/hamlets/embed.hamlet") + +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 _x <- (list theArg) + x +|] + +caseListChain :: Assertion +caseListChain = do + helper "urlurlurl" [hamlet| +$forall x <- list(getArg(getArg(getArg(getArg(getArg (theArg)))))) + @{url x} +|] + +caseWith :: Assertion +caseWith = do + helper "it's embedded" [hamlet| +$with n <- embed theArg + it's ^{n}ded +|] + +caseWithMulti :: Assertion +caseWithMulti = do + helper "it's embedded" [hamlet| +$with n <- embed theArg, m <- true theArg + $if m + it's ^{n}ded +|] + +caseWithChain :: Assertion +caseWithChain = do + helper "it's true" [hamlet| +$with n <- true(getArg(getArg(getArg(getArg theArg)))) + $if n + it's true +|] + +-- in multi-with binding, make sure that a comma in a string doesn't confuse the parser. +caseWithCommaString :: Assertion +caseWithCommaString = do + helper "it's , something" [hamlet| +$with n <- " , something" + it's #{n} +|] + +caseWithMultiBindingScope :: Assertion +caseWithMultiBindingScope = do + helper "it's , something" [hamlet| +$with n <- " , something", y <- n + it's #{y} +|] + +caseScriptNotEmpty :: Assertion +caseScriptNotEmpty = helper "<script></script>\n" [hamlet|<script>|] + +caseMetaEmpty :: Assertion +caseMetaEmpty = do + helper "<meta>\n" [hamlet|<meta>|] + helper "<meta/>\n" [xhamlet|<meta>|] + +caseInputEmpty :: Assertion +caseInputEmpty = do + helper "<input>\n" [hamlet|<input>|] + helper "<input/>\n" [xhamlet|<input>|] + +caseMultiClass :: Assertion +caseMultiClass = helper "<div class=\"foo bar\"></div>\n" [hamlet|<.foo.bar>|] + +caseAttribOrder :: Assertion +caseAttribOrder = + helper "<meta 1 2 3>\n" [hamlet|<meta 1 2 3>|] + +caseNothing :: Assertion +caseNothing = do + helper "" [hamlet| +$maybe _n <- nothing theArg + nothing +|] + helper "nothing" [hamlet| +$maybe _n <- nothing theArg + something +$nothing + nothing +|] + +caseNothingChain :: Assertion +caseNothingChain = helper "" [hamlet| +$maybe n <- nothing(getArg(getArg(getArg theArg))) + nothing #{n} +|] + +caseJust :: Assertion +caseJust = helper "it's just" [hamlet| +$maybe n <- just theArg + it's #{n} +|] + +caseJustChain :: Assertion +caseJustChain = helper "it's just" [hamlet| +$maybe n <- just(getArg(getArg(getArg theArg))) + it's #{n} +|] + +caseConstructor :: Assertion +caseConstructor = do + helper "url" [hamlet|@{Home}|] + helper "suburl" [hamlet|@{Sub SubUrl}|] + let text = "<raw text>" + helper "<raw text>" [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| +$newline never +\#this is raw +\ +\ +|] + helper "$@^" [hamlet|\$@^|] + +caseEmptyStatementList :: Assertion +caseEmptyStatementList = do + helper "" [hamlet|$if True|] + helper "" [hamlet|$maybe _x <- Nothing|] + let emptyList = [] + helper "" [hamlet|$forall _x <- emptyList|] + +caseAttribCond :: Assertion +caseAttribCond = do + helper "<select></select>\n" [hamlet|<select :False:selected>|] + helper "<select selected></select>\n" [hamlet|<select :True:selected>|] + helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|] + helper "<select selected></select>\n" + [hamlet|<select :true theArg:selected>|] + + helper "<select></select>\n" [hamlet|<select :False:selected>|] + helper "<select selected></select>\n" [hamlet|<select :True:selected>|] + helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|] + helper "<select selected></select>\n" + [hamlet|<select :true theArg:selected>|] + +caseNonAscii :: Assertion +caseNonAscii = do + helper "עִבְרִי" [hamlet|עִבְרִי|] + +caseMaybeFunction :: Assertion +caseMaybeFunction = do + helper "url?foo=bar&foo1=bar1" [hamlet| +$maybe x <- Just urlParams + @?{x theArg} +|] + +caseTrailingDollarSign :: Assertion +caseTrailingDollarSign = + helper "trailing space \ndollar sign #" [hamlet| +$newline never +trailing space # +\ +dollar sign #\ +|] + +caseNonLeadingPercent :: Assertion +caseNonLeadingPercent = + helper "<span style=\"height:100%\">foo</span>" [hamlet| +$newline never +<span style=height:100%>foo +|] + +caseQuotedAttribs :: Assertion +caseQuotedAttribs = + helper "<input type=\"submit\" value=\"Submit response\">" [hamlet| +$newline never +<input type=submit value="Submit response"> +|] + +caseSpacedDerefs :: Assertion +caseSpacedDerefs = do + helper "<var>" [hamlet|#{var theArg}|] + helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] + +caseAttribVars :: Assertion +caseAttribVars = do + helper "<div id=\"<var>\"></div>\n" [hamlet|<##{var theArg}>|] + helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] + helper "<div f=\"<var>\"></div>\n" [hamlet|< f=#{var theArg}>|] + + helper "<div id=\"<var>\"></div>\n" [hamlet|<##{var theArg}>|] + helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] + helper "<div f=\"<var>\"></div>\n" [hamlet|< f=#{var theArg}>|] + +caseStringsAndHtml :: Assertion +caseStringsAndHtml = do + let str = "<string>" + let html = preEscapedString "<html>" + helper "<string> <html>" [hamlet|#{str} #{html}|] + +caseNesting :: Assertion +caseNesting = do + helper + "<table><tbody><tr><td>1</td></tr><tr><td>2</td></tr></tbody></table>" + [hamlet| +$newline never +<table> + <tbody> + $forall user <- users + <tr> + <td>#{user} +|] + helper + (concat + [ "<select id=\"foo\" name=\"foo\"><option selected></option>" + , "<option value=\"true\">Yes</option>" + , "<option value=\"false\">No</option>" + , "</select>" + ]) + [hamlet| +$newline never +<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 :: Int + 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\n<br>\n" $(hamletFile "test/hamlets/external.hamlet") + helper "foo\n<br/>\n" $(xhamletFile "test/hamlets/external.hamlet") + helper "foo\n<br>\n" $(hamletFileReload "test/hamlets/external.hamlet") + where + foo = "foo" + +caseParens :: Assertion +caseParens = do + let plus = (++) + x = "x" + y = "y" + helper "xy" [hamlet|#{(plus x) y}|] + helper "xxy" [hamlet|#{plus (plus x x) y}|] + let alist = ["1", "2", "3"] + helper "123" [hamlet| +$forall x <- (id id id id alist) + #{x} +|] + +caseHamletLiterals :: Assertion +caseHamletLiterals = do + helper "123" [hamlet|#{show 123}|] + helper "123.456" [hamlet|#{show 123.456}|] + helper "-123" [hamlet|#{show -123}|] + helper "-123.456" [hamlet|#{show -123.456}|] + +helper' :: String -> Html -> Assertion +helper' res h = T.pack res @=? Text.Blaze.Html.Renderer.Text.renderHtml h + +caseHamlet' :: Assertion +caseHamlet' = do + helper' "foo" [shamlet|foo|] + helper' "foo" [xshamlet|foo|] + helper "<br>\n" $ const $ [shamlet|<br>|] + helper "<br/>\n" $ const $ [xshamlet|<br>|] + + -- new with generalized stuff + helper' "foo" [shamlet|foo|] + helper' "foo" [xshamlet|foo|] + helper "<br>\n" $ const $ [shamlet|<br>|] + helper "<br/>\n" $ const $ [xshamlet|<br>|] + + +instance Show Url where + show _ = "FIXME remove this instance show Url" + +caseDiffBindNames :: Assertion +caseDiffBindNames = do + let list = words "1 2 3" + -- FIXME helper "123123" $(hamletFileReload "test/hamlets/external-debug3.hamlet") + error "test has been disabled" + + +caseTrailingSpaces :: Assertion +caseTrailingSpaces = helper "" [hamlet| +$if True +$elseif False +$else +$maybe x <- Nothing +$nothing +$forall x <- empty +|] + where + empty = [] + + + +caseTuple :: Assertion +caseTuple = do + helper "(1,1)" [hamlet| #{("1","1")}|] + helper "foo" [hamlet| + $with (a,b) <- ("foo","bar") + #{a} + |] + helper "url" [hamlet| + $with (a,b) <- (Home,Home) + @{a} + |] + helper "url" [hamlet| + $with p <- (Home,[]) + @?{p} + |] + + + +caseComplex :: Assertion +caseComplex = do + let z :: ((Int,Int),Maybe Int,(),Bool,[[Int]]) + z = ((1,2),Just 3,(),True,[[4],[5,6]]) + helper "1 2 3 4 5 61 2 3 4 5 6" [hamlet| + $with ((a,b),Just c, () ,True,d@[[e],[f,g]]) <- z + $forall h <- d + #{a} #{b} #{c} #{e} #{f} #{g} + |] + +caseRecord :: Assertion +caseRecord = do + let z = ARecord 10 True + helper "10" [hamlet| + $with ARecord { field1, field2 = True } <- z + #{field1} + |] + +caseRecordWildCard :: Assertion +caseRecordWildCard = do + let z = ARecord 10 True + helper "10 True" [hamlet| + $with ARecord {..} <- z + #{field1} #{field2} + |] + +caseRecordWildCard1 :: Assertion +caseRecordWildCard1 = do + let z = ARecord 10 True + helper "10" [hamlet| + $with ARecord {field2 = True, ..} <- z + #{field1} + |] + +caseCaseRecord :: Assertion +caseCaseRecord = do + let z = ARecord 10 True + helper "10\nTrue" [hamlet| + $case z + $of ARecord { field1, field2 = x } + #{field1} + #{x} + |] + +data Msg = Hello | Goodbye + +ihelper :: String -> HtmlUrlI18n Msg Url -> Assertion +ihelper res h = do + let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h showMsg render + T.pack res @=? x + where + showMsg Hello = preEscapedString "Hola" + showMsg Goodbye = preEscapedString "Adios" + +instance (ToMarkup a, ToMarkup b) => ToMarkup (a,b) where + toMarkup (a,b) = do + toMarkup "(" + toMarkup a + toMarkup "," + toMarkup b + toMarkup ")"
+ test/Text/JuliusSpec.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +module Text.JuliusSpec (spec) where + +import Test.HUnit hiding (Test) +import Test.Hspec + +import Prelude hiding (reverse) +#ifdef TEST_COFFEE +import Text.Coffee +#endif +import Text.Julius +import Quoter (quote, quoteFile, quoteFileReload) +import Data.List (intercalate) +import qualified Data.Text.Lazy as T +import qualified Data.List +import qualified Data.List as L +import Data.Text (Text, pack, unpack) +import Data.Monoid (mappend) +import Data.Aeson (toJSON) + +join :: [String] -> String +#ifdef TEST_COFFEE +join l = (intercalate ";\n" l) +#else +join = intercalate "\n" +#endif + +spec :: Spec +spec = do +#if !(defined TEST_COFFEE || defined TEST_ROY) + it "julius" $ do + let var = "x=2" + let urlp = (Home, [(pack "p", pack "q")]) + flip jelper [quote|['שלום', @{Home}, #{rawJS var}, '@?{urlp}', ^{jmixin} ]|] + $ intercalate " " + [ "['שלום'," + , "url, " ++ var ++ "," + , "'url?p=q'," + , "f(2) ]" + ] + + + it "juliusFile" $ do + let var = "x=2" + let urlp = (Home, [(pack "p", pack "q")]) + flip jelper $(quoteFile "test/juliuses/external1.julius") $ join + [ "שלום" + , var + , "url" + , "url?p=q" + , "f(2)" + ] ++ "\n" + + + it "juliusFileReload" $ do + let var = "x=2" + let urlp = (Home, [(pack "p", pack "q")]) + flip jelper $(quoteFileReload "test/juliuses/external1.julius") $ join + [ "שלום" + , var + , "url" + , "url?p=q" + , "f(2)" + ] ++ "\n" +#endif + +{- TODO + it "juliusFileDebugChange" $ do + let var = "somevar" + test result = jelper result $(juliusFileDebug "test/juliuses/external2.julius") + writeFile "test/juliuses/external2.julius" "var #{var} = 1;" + test "var somevar = 1;" + writeFile "test/juliuses/external2.julius" "var #{var} = 2;" + test "var somevar = 2;" + writeFile "test/juliuses/external2.julius" "var #{var} = 1;" + -} + + + it "julius module names" $ + let foo = "foo" + double = 3.14 :: Double + int = -5 :: Int +#ifdef TEST_COFFEE + in jelper "var _this = this;\n\n(function(shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint) {\n return [shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint];\n})(oof, oof, 3.14, -5);\n" +#else +# ifdef TEST_ROY + in jelper "(function(shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint) {\n return [shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint];\n})(oof, oof, 3.14, -5);\n" +# else + in jelper "[oof, oof, 3.14, -5]" +# endif +#endif + [quote|[#{rawJS $ Data.List.reverse foo}, #{rawJS $ L.reverse foo}, #{rawJS $ show double}, #{rawJS $ show int}]|] + + +-- not valid coffeescript +#if !(defined TEST_COFFEE || defined TEST_ROY) + it "single dollar at and caret" $ do + jelper "$@^" [quote|$@^|] + jelper "#{@{^{" [quote|#\{@\{^\{|] +#endif + + it "dollar operator" $ do + let val = (1 :: Int, (2 :: Int, 3 :: Int)) +#if (defined TEST_COFFEE) + jelper "var _this = this;\n\n(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] + jelper "var _this = this;\n\n(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] +#else + +# if (defined TEST_ROY) + jelper "(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] + jelper "(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] + +# else + jelper "2" [quote|#{ rawJS $ show $ fst $ snd val }|] + jelper "2" [quote|#{ rawJS $ show $ fst $ snd $ val}|] +# endif +#endif + +#if (defined TEST_ROY) + it "roy function wrapper" $ do + let royInsert = rawJS "\"royInsert\"" + jelper "(function(shakespeare_var_royInsert) {\n var roy = {\n \"royInsert\": shakespeare_var_royInsert\n };\n return console.log(roy);\n})(\"royInsert\");\n" [quote| +let roy = { royInsert: #{royInsert} } +console.log roy +|] +#endif + it "empty file" $ jelper "" [quote||] + + it "JSON data" $ jelper "\"Hello \\\"World!\\\"\"" [julius|#{toJSON "Hello \"World!\""}|] + + it "< escaping" $ jelper "\"\\u003c\"" [julius|#{toJSON "<"}|] + + it "> escaping" $ jelper "\"\\u003e\"" [julius|#{toJSON ">"}|] + + it "& escaping" $ jelper "\"\\u0026\"" [julius|#{toJSON "&"}|] + + it "boolean interpolation" $ jelper + "true false true false true false" + [julius|#{True} #{False} #{toJSON True} #{toJSON False} #{rawJS True} #{rawJS False}|] + + it "^\\ should not be escaped" $ jelper + "var re = /[^\\r]/;" + [julius|var re = /[^\r]/;|] + + it "^\\{ should be escaped" $ jelper + "var re = /[^{]/;" + [julius|var re = /[^\{]/;|] + + +data Url = Home | Sub SubUrl +data SubUrl = SubUrl +render :: Url -> [(Text, Text)] -> Text +render Home qs = pack "url" `mappend` showParams qs +render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs + +showParams :: [(Text, Text)] -> Text +showParams [] = pack "" +showParams z = + pack $ '?' : intercalate "&" (map go z) + where + go (x, y) = go' x ++ '=' : go' y + go' = concatMap encodeUrlChar . unpack + +-- | 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] + + + + +#ifndef TEST_ROY +jmixin :: JavascriptUrl u +jmixin = [quote|f(2)|] +#endif + +jelper :: String -> JavascriptUrl Url -> Assertion +jelper res h = do + T.pack res @=? renderJavascriptUrl render h + +instance Show Url where + show _ = "FIXME remove this instance show Url"
test/Text/Shakespeare/BaseSpec.hs view
@@ -12,7 +12,7 @@ -- run :: Text.Parsec.Prim.Parsec Text.Parsec.Pos.SourceName () c -> Text.Parsec.Pos.SourceName -> c spec :: Spec-spec = describe "shakespeare-js" $ do+spec = do let preFilterN = preFilter Nothing {- it "parseStrings" $ do
− test/Text/Shakespeare/CssSpec.hs
@@ -1,612 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -O0 #-} -module Text.Shakespeare.CssSpec (spec) where - -import Test.HUnit hiding (Test) -import Test.Hspec - -import Prelude hiding (reverse) -import Text.Cassius -import Text.Lucius -import Data.List (intercalate) -import qualified Data.Text.Lazy as T -import qualified Data.Text as TS -import qualified Data.List -import qualified Data.List as L -import Data.Text (Text, pack, unpack) -import Data.Monoid (mappend) - -spec :: Spec -spec = do - describe "shakespeare-css" $ do - it "cassius" caseCassius - it "cassiusFile" caseCassiusFile - it "cassius single comment" caseCassiusSingleComment - it "cassius leading comment" caseCassiusLeadingComment - - it "cassiusFileDebug" $ do - let var = "var" - let selector = "foo" - let urlp = (Home, [(pack "p", pack "q")]) - flip celper $(cassiusFileDebug "test/cassiuses/external1.cassius") $ concat - [ "foo {\n background: #000;\n bar: baz;\n color: #F00;\n}\n" - , "bin {\n" - , " background-image: url(url);\n" - , " bar: bar;\n color: #7F6405;\n fvarx: someval;\n unicode-test: שלום;\n" - , " urlp: url(url?p=q);\n}\n" - ] - -{- TODO - it "cassiusFileDebugChange" $ do - let var = "var" - writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" - celper "foo{var:1}" $(cassiusFileDebug "test/cassiuses/external2.cassius") - writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 2" - celper "foo{var:2}" $(cassiusFileDebug "test/cassiuses/external2.cassius") - writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" - -} - - - it "comments" $ do - -- FIXME reconsider Hamlet comment syntax? - celper "" [cassius|/* this is a comment */ -/* another comment */ -/*a third one*/|] - - - it "cassius pseudo-class" $ - flip celper [cassius| -a:visited - color: blue -|] "a:visited{color:blue}" - - - it "ignores a blank line" $ do - celper "foo{bar:baz}" [cassius| -foo - - bar: baz - -|] - - - it "leading spaces" $ - celper "foo{bar:baz}" [cassius| - foo - bar: baz -|] - - - it "cassius all spaces" $ - celper "h1{color:green }" [cassius| - h1 - color: green - |] - - - it "cassius whitespace and colons" $ do - celper "h1:hover{color:green ;font-family:sans-serif}" [cassius| - h1:hover - color: green - font-family:sans-serif - |] - - - it "cassius trailing comments" $ - 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 - |] - - it "cassius nesting" $ - celper "foo bar{baz:bin}" [cassius| - foo - bar - baz: bin - |] - - it "cassius variable" $ - celper "foo bar{baz:bin}" [cassius| - @binvar: bin - foo - bar - baz: #{binvar} - |] - - it "cassius trailing semicolon" $ - celper "foo bar{baz:bin}" [cassius| - @binvar: bin - foo - bar - baz: #{binvar}; - |] - - - - it "cassius module names" $ do - let foo = "foo" - dub = 3.14::Double - int = -5::Int - celper "sel{bar:oof oof 3.14 -5}" - [cassius| -sel - bar: #{Data.List.reverse foo} #{L.reverse foo} #{show dub} #{show int} -|] - - - - it "single dollar at and caret" $ do - celper "sel{att:$@^}" [cassius| -sel - att: $@^ -|] - - {- - celper "sel{att:#{@{^{}" [cassius| -sel - att: #\{@\{^{ -|] --} - - - it "dollar operator" $ do - let val = (1, (2, 3)) :: (Integer, (Integer, Integer)) - celper "sel{att:2}" [cassius| -sel - att: #{ show $ fst $ snd val } -|] - celper "sel{att:2}" [cassius| -sel - att: #{ show $ fst $ snd $ val} -|] - - - - it "embedded slash" $ do - celper "sel{att:///}" [cassius| -sel - att: /// -|] - - - - - - - it "multi cassius" $ do - celper "foo{bar:baz;bar:bin}" [cassius| -foo - bar: baz - bar: bin -|] - - - - - - - it "lucius" $ do - let var = "var" - let urlp = (Home, [(pack "p", pack "q")]) - flip celper [lucius| -foo { - background: #{colorBlack}; - bar: baz; - color: #{colorRed}; -} -bin { - background-image: url(@{Home}); - bar: bar; - color: #{(((Color 127) 100) 5)}; - f#{var}x: someval; - unicode-test: שלום; - urlp: url(@?{urlp}); -} -|] $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - - - - it "lucius file" $ do - let var = "var" - let urlp = (Home, [(pack "p", pack "q")]) - flip celper $(luciusFile "test/cassiuses/external1.lucius") $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - - it "lucius file debug" caseLuciusFileDebug - - - - - it "lucius nested" $ do - celper "foo bar{baz:bin}" $(luciusFile "test/cassiuses/external-nested.lucius") - celper "foo bar {\n baz: bin;\n}\n" $(luciusFileDebug "test/cassiuses/external-nested.lucius") - celper "foo bar{baz:bin}" [lucius| - foo { - bar { - baz: bin; - } - } - |] - celper "foo1 bar,foo2 bar{baz:bin}" [lucius| - foo1, foo2 { - bar { - baz: bin; - } - } - |] - - - it "lucius charset" $ do - celper (concat ["@charset \"utf-8\";" - , "#content ul{list-style:none;padding:0 5em}" - , "#content ul li{padding:1em 0}" - , "#content ul li a{color:#419a56;font-family:'TeXGyreHerosBold',helvetica,arial,sans-serif;font-weight:bold;text-transform:uppercase;white-space:nowrap}" - ]) [lucius| -@charset "utf-8"; -#content ul -{ - list-style: none; - padding: 0 5em; - li - { - padding: 1em 0; - a - { - color: #419a56; - font-family: 'TeXGyreHerosBold',helvetica,arial,sans-serif; - font-weight: bold; - text-transform: uppercase; - white-space: nowrap; - } - } -} -|] - - it "lucius media" $ do - celper "@media only screen{foo bar{baz:bin}}" $(luciusFile "test/cassiuses/external-media.lucius") - celper "@media only screen {\n foo bar {\n baz: bin;\n }\n}\n" $(luciusFileDebug "test/cassiuses/external-media.lucius") - celper "@media only screen{foo bar{baz:bin}}" [lucius| - @media only screen{ - foo { - bar { - baz: bin; - } - } - } - |] - - - {- - it "cassius removes whitespace" $ do - celper "foo{bar:baz}" [cassius| - foo - bar : baz - |] - -} - - - - - - it "lucius trailing comments" $ - celper "foo{bar:baz}" [lucius|foo{bar:baz;}/* ignored*/|] - - it "lucius variables" $ celper "foo{bar:baz}" [lucius| -@myvar: baz; -foo { - bar: #{myvar}; -} -|] - it "lucius CDO/CDC tokens" $ - celper "*{a:b}" [lucius| -<!-- --> <!-- -* { - a: b; -} ---> -|] - it "lucius @import statements" $ - celper "@import url(\"bla.css\");" [lucius| -@import url("bla.css"); -|] - it "lucius simple escapes" $ - celper "*{a:test}" [lucius| -* { - a: t\65 st; -} -|] - it "lucius bounded escapes" $ - celper "*{a:teft}" [lucius| -* { - a: t\000065ft; -} -|] - it "lucius case-insensitive keywords" $ - celper "@media foo {}" [lucius| -@MeDIa foo { -} -|] - it "lucius @page statements" $ - celper "@page :right{a:b;c:d}" [lucius| -@page :right { -a:b; -c:d; -} -|] - it "lucius @font-face statements" $ - celper "@font-face{a:b;c:d}" [lucius| -@font-face { -a:b; -c:d; -} -|] - it "lucius runtime" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "foo { bar: #{myvar}}") [(TS.pack "myvar", TS.pack "baz")] - it "lucius runtime variables" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "@dummy: dummy; @myvar: baz; @dummy2: dummy; foo { bar: #{myvar}}") [] - it "lucius whtiespace" $ Right (T.pack "@media foo {\n bar {\n baz: bin;\n baz2: bin2;\n }\n}\n") - @=? luciusRT (T.pack "@media foo{bar{baz:bin;baz2:bin2}}") [] - it "variables inside value" $ - celper "foo{foo:XbarY}" [lucius| -@bar: bar; -foo { foo:X#{bar}Y; } -|] - it "variables in media selector" $ - celper "@media (max-width: 400px){foo{color:red}}" [lucius| -@mobileWidth: 400px; -@media (max-width: #{mobileWidth}){ foo { color: red; } } -|] - it "URLs in import" $ celper - "@import url(\"suburl\");" [lucius| -@import url("@{Sub SubUrl}"); -|] - it "vars in charset" $ do - let charset = "mycharset" - celper "@charset mycharset;" [lucius| -@charset #{charset}; -|] - it "keyframes" $ celper - "@keyframes mymove {from{top:0px}to{top:200px}}" [lucius| -@keyframes mymove { - from { - top: 0px; - } - to { - top: 200px; - } -} -|] - it "prefixed keyframes" $ celper - "@-webkit-keyframes mymove {from{top:0px}to{top:200px}}" [lucius| -@-webkit-keyframes mymove { - from { - top: 0px; - } - to { - top: 200px; - } -} -|] - it "lucius mixins" $ do - let bins = [luciusMixin| - bin:bin2; - /* FIXME not currently implementing sublocks in mixins - foo2 { - x: y - } - */ - |] :: Mixin - -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| - celper "foo{bar:baz;bin:bin2}" [lucius| - foo { - bar: baz; - ^{bins} - } - |] - it "cassius mixins" $ do - let bins = [cassiusMixin| - bin:bin2 - bin3:bin4 - |] :: Mixin - -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| - celper "foo{bar:baz;bin:bin2;bin3:bin4}" [lucius| - foo { - bar: baz; - ^{bins} - } - |] - it "more complicated mixins" $ do - let transition val = - [luciusMixin| - -webkit-transition: #{val}; - -moz-transition: #{val}; - -ms-transition: #{val}; - -o-transition: #{val}; - transition: #{val}; - |] - - celper ".some-class{-webkit-transition:all 4s ease;-moz-transition:all 4s ease;-ms-transition:all 4s ease;-o-transition:all 4s ease;transition:all 4s ease}" - [lucius| - .some-class { - ^{transition "all 4s ease"} - } - |] - - it "runtime mixin" $ do - let bins = [luciusMixin| - bin:bin2; - /* FIXME not currently implementing sublocks in mixins - foo2 { - x: y - } - */ - |] :: Mixin - -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| - Right (T.pack "foo{bar:baz;bin:bin2}") @=? luciusRTMixin - (T.pack "foo { bar: baz; ^{bins} }") - True - [(TS.pack "bins", RTVMixin bins)] - - it "luciusFileReload mixin" $ do - let mixin = [luciusMixin|foo:bar;baz:bin|] - flip celper $(luciusFileReload "test/cassiuses/mixin.lucius") $ concat - [ "selector {\n foo: bar;\n baz: bin;\n}\n" - ] - - it "cassiusFileReload with import URL" $ do - celper - "@import url(url);\n" - $(cassiusFileReload "test/cassiuses/reload-import.cassius") - - it "& subblocks" $ - celper "foo:bar{baz:bin}" - [lucius| - foo { - &:bar { - baz: bin; - } - } - |] - - describe "font-face #139" $ do - it "lucius" $ - celper "@font-face{font-family:myFirstFont;src:url(sansation_light.woff)}" - [lucius| - @font-face { - font-family: myFirstFont; - src: url(sansation_light.woff); - } - |] - it "cassius" $ - celper "@font-face{font-family:myFirstFont;src:url(sansation_light.woff)}" - [cassius| - @font-face - font-family: myFirstFont - src: url(sansation_light.woff) - |] - -data Url = Home | Sub SubUrl -data SubUrl = SubUrl -render :: Url -> [(Text, Text)] -> Text -render Home qs = pack "url" `mappend` showParams qs -render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs - -showParams :: [(Text, Text)] -> Text -showParams [] = pack "" -showParams z = - pack $ '?' : intercalate "&" (map go z) - where - go (x, y) = go' x ++ '=' : go' y - go' = concatMap encodeUrlChar . unpack - --- | 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] - - - -celper :: String -> CssUrl Url -> Assertion -celper res h = do - let x = renderCssUrl render h - T.pack res @=? x - -caseCassius :: Assertion -caseCassius = do - let var = "var" - let urlp = (Home, [(pack "p", pack "q")]) - flip celper [cassius| -foo - background: #{colorBlack} - bar: baz - color: #{colorRed} -bin - background-image: url(@{Home}) - bar: bar - color: #{(((Color 127) 100) 5)} - f#{var}x: someval - unicode-test: שלום - urlp: url(@?{urlp}) -|] $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - -caseCassiusFile :: Assertion -caseCassiusFile = do - let var = "var" - let selector = "foo" - let urlp = (Home, [(pack "p", pack "q")]) - flip celper $(cassiusFile "test/cassiuses/external1.cassius") $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - -caseCassiusSingleComment :: Assertion -caseCassiusSingleComment = - flip celper [cassius| - /* - this is a comment - */ - |] "" - -caseCassiusLeadingComment :: Assertion -caseCassiusLeadingComment = - flip celper [cassius| - /* - this is a comment - */ - sel1 - foo: bar - sel2 - baz: bin - |] "sel1{foo:bar}sel2{baz:bin}" - -instance Show Url where - show _ = "FIXME remove this instance show Url" - - -caseLuciusFileDebug :: Assertion -caseLuciusFileDebug = do - let var = "var" - writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}" - celper "foo {\n var: 1;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") - writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 2}" - celper "foo {\n var: 2;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") - writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}"
− test/Text/Shakespeare/HamletSpec.hs
@@ -1,1067 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-module Text.Shakespeare.HamletSpec (spec) where--import HamletTestTypes (ARecord(..))--import Test.HUnit hiding (Test)-import Test.Hspec hiding (Arg)--import Prelude hiding (reverse)-import Text.Hamlet-import Text.Hamlet.RT-import Data.List (intercalate)-import qualified Data.Text.Lazy as T-import qualified Data.List-import qualified Data.List as L-import Data.Text (Text, pack, unpack)-import Data.Monoid (mappend)-import qualified Data.Set as Set-import qualified Text.Blaze.Html.Renderer.Text-import Text.Blaze.Html (toHtml)-import Text.Blaze.Internal (preEscapedString)-import Text.Blaze--spec = do- describe "hamlet" $ do- it "empty" caseEmpty- it "static" caseStatic- it "tag" caseTag- it "var" caseVar- it "var chain " caseVarChain- it "url" caseUrl- it "url chain " caseUrlChain- it "embed" caseEmbed- it "embed chain " caseEmbedChain- it "if" caseIf- it "if chain " caseIfChain- it "else" caseElse- it "else chain " caseElseChain- it "elseif" caseElseIf- it "elseif chain " caseElseIfChain- it "list" caseList- it "list chain" caseListChain- it "with" caseWith- it "with multi" caseWithMulti- it "with chain" caseWithChain- it "with comma string" caseWithCommaString- it "with multi scope" caseWithMultiBindingScope- it "script not empty" caseScriptNotEmpty- it "meta empty" caseMetaEmpty- it "input empty" caseInputEmpty- it "multiple classes" caseMultiClass- it "attrib order" caseAttribOrder- it "nothing" caseNothing- it "nothing chain " caseNothingChain- it "just" caseJust- it "just chain " caseJustChain- it "constructor" caseConstructor- it "url + params" caseUrlParams- it "escape" caseEscape- it "empty statement list" caseEmptyStatementList- it "attribute conditionals" caseAttribCond- it "non-ascii" caseNonAscii- it "maybe function" caseMaybeFunction- it "trailing dollar sign" caseTrailingDollarSign- it "non leading percent sign" caseNonLeadingPercent- it "quoted attributes" caseQuotedAttribs- it "spaced derefs" caseSpacedDerefs- it "attrib vars" caseAttribVars- it "strings and html" caseStringsAndHtml- it "nesting" caseNesting- it "trailing space" caseTrailingSpace- it "currency symbols" caseCurrency- it "external" caseExternal- it "parens" caseParens- it "hamlet literals" caseHamletLiterals- it "hamlet' and xhamlet'" caseHamlet'- it "hamlet tuple" caseTuple- it "complex pattern" caseComplex- it "record pattern" caseRecord- it "record wildcard pattern #1" caseRecordWildCard- it "record wildcard pattern #2" caseRecordWildCard1---- it "comments" $ do- -- FIXME reconsider Hamlet comment syntax?- helper "" [hamlet|$# this is a comment-$# another comment-$#a third one|]--- it "ignores a blank line" $ do- helper "<p>foo</p>\n" [hamlet|-<p>-- foo---|]----- it "angle bracket syntax" $- helper "<p class=\"foo\" height=\"100\"><span id=\"bar\" width=\"50\">HELLO</span></p>"- [hamlet|-$newline never-<p.foo height="100">- <span #bar width=50>HELLO-|]---- it "hamlet module names" $ do- let foo = "foo"- helper "oof oof 3.14 -5"- [hamlet|-$newline never-#{Data.List.reverse foo} #-#{L.reverse foo} #-#{show 3.14} #{show -5}|]------ it "single dollar at and caret" $ do- helper "$@^" [hamlet|\$@^|]-- helper "#{@{^{" [hamlet|#\{@\{^\{|]--- it "dollar operator" $ do- let val = (1, (2, 3))- helper "2" [hamlet|#{ show $ fst $ snd val }|]- helper "2" [hamlet|#{ show $ fst $ snd $ val}|]--- it "in a row" $ do- helper "1" [hamlet|#{ show $ const 1 2 }|]--- it "embedded slash" $ do- helper "///" [hamlet|///|]--{- compile-time error- it "tag with slash" $ do- helper "" [hamlet|-<p>- Text-</p>-|]--}-- it "string literals" $ do- helper "string" [hamlet|#{"string"}|]- helper "string" [hamlet|#{id "string"}|]- helper "gnirts" [hamlet|#{L.reverse $ id "string"}|]- helper "str"ing" [hamlet|#{"str\"ing"}|]- helper "str<ing" [hamlet|#{"str<ing"}|]--- it "interpolated operators" $ do- helper "3" [hamlet|#{show $ (+) 1 2}|]- helper "6" [hamlet|#{show $ sum $ (:) 1 ((:) 2 $ return 3)}|]--- it "HTML comments" $ do- helper "<p>1</p><p>2 not ignored</p>" [hamlet|-$newline never-<p>1-<!-- ignored comment -->-<p>- 2- <!-- ignored --> not ignored<!-- ignored -->-|]-- it "Keeps SSI includes" $- helper "<!--# SSI -->" [hamlet|<!--# SSI -->|]---- it "nested maybes" $ do- let muser = Just "User" :: Maybe String- mprof = Nothing :: Maybe Int- m3 = Nothing :: Maybe String- helper "justnothing" [hamlet|-$maybe user <- muser- $maybe profile <- mprof- First two are Just- $maybe desc <- m3- \ and left us a description:- <p>#{desc}- $nothing- and has left us no description.- $nothing- justnothing-$nothing- <h1>No such Person exists.- |]--- it "maybe with qualified constructor" $ do- helper "5" [hamlet|- $maybe HamletTestTypes.ARecord x y <- Just $ ARecord 5 True- \#{x}- |]-- it "record with qualified constructor" $ do- helper "5" [hamlet|- $maybe HamletTestTypes.ARecord {..} <- Just $ ARecord 5 True- \#{field1}- |]----- it "conditional class" $ do- helper "<p class=\"current\"></p>\n"- [hamlet|<p :False:.ignored :True:.current>|]-- helper "<p class=\"1 3 2 4\"></p>\n"- [hamlet|<p :True:.1 :True:class=2 :False:.a :False:class=b .3 class=4>|]-- helper "<p class=\"foo bar baz\"></p>\n"- [hamlet|<p class=foo class=bar class=baz>|]----- it "forall on Foldable" $ do- let set = Set.fromList [1..5 :: Int]- helper "12345" [hamlet|-$forall x <- set- #{x}-|]---- it "non-poly HTML" $ do- helperHtml "<h1>HELLO WORLD</h1>\n" [shamlet|- <h1>HELLO WORLD- |]- helperHtml "<h1>HELLO WORLD</h1>\n" $(shamletFile "test/hamlets/nonpolyhtml.hamlet")- helper "<h1>HELLO WORLD</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhtml.hamlet")--- it "non-poly Hamlet" $ do- let embed = [hamlet|<p>EMBEDDED|]- helper "<h1>url</h1>\n<p>EMBEDDED</p>\n" [hamlet|- <h1>@{Home}- ^{embed}- |]- helper "<h1>url</h1>\n" $(hamletFile "test/hamlets/nonpolyhamlet.hamlet")- helper "<h1>url</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhamlet.hamlet")-- it "non-poly IHamlet" $ do- let embed = [ihamlet|<p>EMBEDDED|]- ihelper "<h1>Adios</h1>\n<p>EMBEDDED</p>\n" [ihamlet|- <h1>_{Goodbye}- ^{embed}- |]- ihelper "<h1>Hola</h1>\n" $(ihamletFile "test/hamlets/nonpolyihamlet.hamlet")- ihelper "<h1>Hola</h1>\n" $(ihamletFileReload "test/hamlets/nonpolyihamlet.hamlet")-- it "pattern-match tuples: forall" $ do- let people = [("Michael", 26), ("Miriam", 25)]- helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet|-$newline never-<dl>- $forall (name, age) <- people- <dt>#{name}- <dd>#{show age}-|]- it "pattern-match tuples: maybe" $ do- let people = Just ("Michael", 26)- helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet|-$newline never-<dl>- $maybe (name, age) <- people- <dt>#{name}- <dd>#{show age}-|]- it "pattern-match tuples: with" $ do- let people = ("Michael", 26)- helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet|-$newline never-<dl>- $with (name, age) <- people- <dt>#{name}- <dd>#{show age}-|]- it "list syntax for interpolation" $ do- helper "<ul><li>1</li><li>2</li><li>3</li></ul>" [hamlet|-$newline never-<ul>- $forall num <- [1, 2, 3]- <li>#{show num}-|]- it "infix operators" $- helper "5" [hamlet|#{show $ (4 + 5) - (2 + 2)}|]- it "infix operators with parens" $- helper "5" [hamlet|#{show ((+) 1 1 + 3)}|]- it "doctypes" $ helper "<!DOCTYPE html>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" [hamlet|-$newline never-$doctype 5-$doctype strict-|]-- it "case on Maybe" $- let nothing = Nothing- justTrue = Just True- in helper "<br><br><br><br>" [hamlet|-$newline never-$case nothing- $of Just val- $of Nothing- <br>-$case justTrue- $of Just val- $if val- <br>- $of Nothing-$case (Just $ not False)- $of Nothing- $of Just val- $if val- <br>-$case Nothing- $of Just val- $of _- <br>-|]-- it "case on Url" $- let url1 = Home- url2 = Sub SubUrl- in helper "<br>\n<br>\n" [hamlet|-$newline always-$case url1- $of Home- <br>- $of _-$case url2- $of Sub sub- $case sub- $of SubUrl- <br>- $of Home-|]-- it "pattern-match constructors: forall" $ do- let people = [Pair "Michael" 26, Pair "Miriam" 25]- helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet|-$newline text-<dl>- $forall Pair name age <- people- <dt>#{name}- <dd>#{show age}-|]- it "pattern-match constructors: maybe" $ do- let people = Just $ Pair "Michael" 26- helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet|-$newline text-<dl>- $maybe Pair name age <- people- <dt>#{name}- <dd>#{show age}-|]- it "pattern-match constructors: with" $ do- let people = Pair "Michael" 26- helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet|-$newline text-<dl>- $with Pair name age <- people- <dt>#{name}- <dd>#{show age}-|]-- it "multiline tags" $ helper- "<foo bar=\"baz\" bin=\"bin\">content</foo>\n" [hamlet|-<foo bar=baz- bin=bin>content-|]- it "*{...} attributes" $- let attrs = [("bar", "baz"), ("bin", "<>\"&")] in helper- "<foo bar=\"baz\" bin=\"<>"&\">content</foo>\n" [hamlet|-<foo *{attrs}>content-|]- it "blank attr values" $ helper- "<foo bar=\"\" baz bin=\"\"></foo>\n"- [hamlet|<foo bar="" baz bin=>|]- it "greater than in attr" $ helper- "<button data-bind=\"enable: someFunction() > 5\">hello</button>\n"- [hamlet|<button data-bind="enable: someFunction() > 5">hello|]- it "normal doctype" $ helper- "<!DOCTYPE html>\n"- [hamlet|<!DOCTYPE html>|]- it "newline style" $ helper- "<p>foo</p>\n<pre>bar\nbaz\nbin</pre>\n"- [hamlet|-$newline always-<p>foo-<pre>- bar- baz- bin-|]- it "avoid newlines" $ helper- "<p>foo</p><pre>barbazbin</pre>"- [hamlet|-$newline always-<p>foo#-<pre>#- bar#- baz#- bin#-|]- it "manual linebreaks" $ helper- "<p>foo</p><pre>bar\nbaz\nbin</pre>"- [hamlet|-$newline never-<p>foo-<pre>- bar- \- baz- \- bin-|]- it "indented newline" $ helper- "<p>foo</p><pre>bar\nbaz\nbin</pre>"- [hamlet|- $newline never- <p>foo- <pre>- bar- \- baz- \- bin-|]- it "case underscore" $- let num = 3- in helper "<p>Many</p>\n" [hamlet|-$case num- $of 1- <p>1- $of 2- <p>2- $of _- <p>Many-|]- it "optional and missing classes" $- helper "<i>foo</i>\n" [hamlet|<i :False:.not-present>foo|]- it "multiple optional and missing classes" $- helper "<i>foo</i>\n" [hamlet|<i :False:.not-present :False:.also-not-here>foo|]- it "optional and present classes" $- helper "<i class=\"present\">foo</i>\n" [hamlet|<i :False:.not-present :True:.present>foo|]- it "punctuation operators #115" $- helper "foo"- [hamlet|- $if True && True- foo- $else- bar- |]-- it "list syntax" $- helper "123"- [hamlet|- $forall x <- []- ignored- $forall x <- [1, 2, 3]- #{show x}- |]-- it "list in attribute" $- let myShow :: [Int] -> String- myShow = show- in helper "<a href=\"[]\">foo</a>\n<a href=\"[1,2]\">bar</a>\n"- [hamlet|- <a href=#{myShow []}>foo- <a href=#{myShow [1, 2]}>bar- |]-- it "AngularJS attribute values #122" $- helper "<li ng-repeat=\"addr in msgForm.new.split(/\\\\s/)\">{{addr}}</li>\n"- [hamlet|<li ng-repeat="addr in msgForm.new.split(/\\s/)">{{addr}}|]-- it "runtime Hamlet with caret interpolation" $ do- let toInclude render = render (5, [("hello", "world")])- let renderer x y = pack $ show (x :: Int, y :: [(Text, Text)])- template1 = "@?{url}"- template2 = "foo^{toInclude}bar"- toInclude <- parseHamletRT defaultHamletSettings template1- hamletRT <- parseHamletRT defaultHamletSettings template2- res <- renderHamletRT hamletRT- [ (["toInclude"], HDTemplate toInclude)- , (["url"], HDUrlParams 5 [(pack "hello", pack "world")])- ] renderer- helperHtml "foo(5,[(\"hello\",\"world\")])bar" res--data Pair = Pair String Int--data Url = Home | Sub SubUrl-data SubUrl = SubUrl-render :: Url -> [(Text, Text)] -> Text-render Home qs = pack "url" `mappend` showParams qs-render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs--showParams :: [(Text, Text)] -> Text-showParams [] = pack ""-showParams z =- pack $ '?' : intercalate "&" (map go z)- where- go (x, y) = go' x ++ '=' : go' y- go' = concatMap encodeUrlChar . unpack---- | 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 :: HtmlUrl url- , true :: Bool- , false :: Bool- , list :: [Arg url]- , nothing :: Maybe String- , just :: Maybe String- , urlParams :: (Url, [(Text, Text)])- }--theArg :: Arg url-theArg = Arg- { getArg = theArg- , var = toHtml "<var>"- , url = Home- , embed = [hamlet|embed|]- , true = True- , false = False- , list = [theArg, theArg, theArg]- , nothing = Nothing- , just = Just "just"- , urlParams = (Home, [(pack "foo", pack "bar"), (pack "foo1", pack "bar1")])- }--helperHtml :: String -> Html -> Assertion-helperHtml res h = do- let x = Text.Blaze.Html.Renderer.Text.renderHtml h- T.pack res @=? x--helper :: String -> HtmlUrl Url -> Assertion-helper res h = do- let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h render- T.pack res @=? x--caseEmpty :: Assertion-caseEmpty = helper "" [hamlet||]--caseStatic :: Assertion-caseStatic = helper "some static content" [hamlet|some static content|]--caseTag :: Assertion-caseTag = do- helper "<p class=\"foo\"><div id=\"bar\">baz</div></p>" [hamlet|-$newline text-<p .foo>- <#bar>baz-|]- helper "<p class=\"foo.bar\"><div id=\"bar\">baz</div></p>" [hamlet|-$newline text-<p class=foo.bar>- <#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 (unpack $ render Home []) [hamlet|@{url theArg}|]--caseUrlChain :: Assertion-caseUrlChain = do- helper (unpack $ render Home []) [hamlet|@{url (getArg (getArg (getArg theArg)))}|]--caseEmbed :: Assertion-caseEmbed = do- helper "embed" [hamlet|^{embed theArg}|]- helper "embed" $(hamletFileReload "test/hamlets/embed.hamlet")- ihelper "embed" $(ihamletFileReload "test/hamlets/embed.hamlet")--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 _x <- (list theArg)- x-|]--caseListChain :: Assertion-caseListChain = do- helper "urlurlurl" [hamlet|-$forall x <- list(getArg(getArg(getArg(getArg(getArg (theArg))))))- @{url x}-|]--caseWith :: Assertion-caseWith = do- helper "it's embedded" [hamlet|-$with n <- embed theArg- it's ^{n}ded-|]--caseWithMulti :: Assertion-caseWithMulti = do- helper "it's embedded" [hamlet|-$with n <- embed theArg, m <- true theArg- $if m- it's ^{n}ded-|]--caseWithChain :: Assertion-caseWithChain = do- helper "it's true" [hamlet|-$with n <- true(getArg(getArg(getArg(getArg theArg))))- $if n- it's true-|]---- in multi-with binding, make sure that a comma in a string doesn't confuse the parser.-caseWithCommaString :: Assertion-caseWithCommaString = do- helper "it's , something" [hamlet|-$with n <- " , something"- it's #{n}-|]--caseWithMultiBindingScope :: Assertion-caseWithMultiBindingScope = do- helper "it's , something" [hamlet|-$with n <- " , something", y <- n- it's #{y}-|]--caseScriptNotEmpty :: Assertion-caseScriptNotEmpty = helper "<script></script>\n" [hamlet|<script>|]--caseMetaEmpty :: Assertion-caseMetaEmpty = do- helper "<meta>\n" [hamlet|<meta>|]- helper "<meta/>\n" [xhamlet|<meta>|]--caseInputEmpty :: Assertion-caseInputEmpty = do- helper "<input>\n" [hamlet|<input>|]- helper "<input/>\n" [xhamlet|<input>|]--caseMultiClass :: Assertion-caseMultiClass = helper "<div class=\"foo bar\"></div>\n" [hamlet|<.foo.bar>|]--caseAttribOrder :: Assertion-caseAttribOrder =- helper "<meta 1 2 3>\n" [hamlet|<meta 1 2 3>|]--caseNothing :: Assertion-caseNothing = do- helper "" [hamlet|-$maybe _n <- nothing theArg- nothing-|]- helper "nothing" [hamlet|-$maybe _n <- nothing theArg- something-$nothing- nothing-|]--caseNothingChain :: Assertion-caseNothingChain = helper "" [hamlet|-$maybe n <- nothing(getArg(getArg(getArg theArg)))- nothing #{n}-|]--caseJust :: Assertion-caseJust = helper "it's just" [hamlet|-$maybe n <- just theArg- it's #{n}-|]--caseJustChain :: Assertion-caseJustChain = helper "it's just" [hamlet|-$maybe n <- just(getArg(getArg(getArg theArg)))- it's #{n}-|]--caseConstructor :: Assertion-caseConstructor = do- helper "url" [hamlet|@{Home}|]- helper "suburl" [hamlet|@{Sub SubUrl}|]- let text = "<raw text>"- helper "<raw text>" [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|-$newline never-\#this is raw-\-\ -|]- helper "$@^" [hamlet|\$@^|]--caseEmptyStatementList :: Assertion-caseEmptyStatementList = do- helper "" [hamlet|$if True|]- helper "" [hamlet|$maybe _x <- Nothing|]- let emptyList = []- helper "" [hamlet|$forall _x <- emptyList|]--caseAttribCond :: Assertion-caseAttribCond = do- helper "<select></select>\n" [hamlet|<select :False:selected>|]- helper "<select selected></select>\n" [hamlet|<select :True:selected>|]- helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|]- helper "<select selected></select>\n"- [hamlet|<select :true theArg:selected>|]-- helper "<select></select>\n" [hamlet|<select :False:selected>|]- helper "<select selected></select>\n" [hamlet|<select :True:selected>|]- helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|]- helper "<select selected></select>\n"- [hamlet|<select :true theArg:selected>|]--caseNonAscii :: Assertion-caseNonAscii = do- helper "עִבְרִי" [hamlet|עִבְרִי|]--caseMaybeFunction :: Assertion-caseMaybeFunction = do- helper "url?foo=bar&foo1=bar1" [hamlet|-$maybe x <- Just urlParams- @?{x theArg}-|]--caseTrailingDollarSign :: Assertion-caseTrailingDollarSign =- helper "trailing space \ndollar sign #" [hamlet|-$newline never-trailing space #-\-dollar sign #\-|]--caseNonLeadingPercent :: Assertion-caseNonLeadingPercent =- helper "<span style=\"height:100%\">foo</span>" [hamlet|-$newline never-<span style=height:100%>foo-|]--caseQuotedAttribs :: Assertion-caseQuotedAttribs =- helper "<input type=\"submit\" value=\"Submit response\">" [hamlet|-$newline never-<input type=submit value="Submit response">-|]--caseSpacedDerefs :: Assertion-caseSpacedDerefs = do- helper "<var>" [hamlet|#{var theArg}|]- helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|]--caseAttribVars :: Assertion-caseAttribVars = do- helper "<div id=\"<var>\"></div>\n" [hamlet|<##{var theArg}>|]- helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|]- helper "<div f=\"<var>\"></div>\n" [hamlet|< f=#{var theArg}>|]-- helper "<div id=\"<var>\"></div>\n" [hamlet|<##{var theArg}>|]- helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|]- helper "<div f=\"<var>\"></div>\n" [hamlet|< f=#{var theArg}>|]--caseStringsAndHtml :: Assertion-caseStringsAndHtml = do- let str = "<string>"- let html = preEscapedString "<html>"- helper "<string> <html>" [hamlet|#{str} #{html}|]--caseNesting :: Assertion-caseNesting = do- helper- "<table><tbody><tr><td>1</td></tr><tr><td>2</td></tr></tbody></table>"- [hamlet|-$newline never-<table>- <tbody>- $forall user <- users- <tr>- <td>#{user}-|]- helper- (concat- [ "<select id=\"foo\" name=\"foo\"><option selected></option>"- , "<option value=\"true\">Yes</option>"- , "<option value=\"false\">No</option>"- , "</select>"- ])- [hamlet|-$newline never-<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 :: Int- 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\n<br>\n" $(hamletFile "test/hamlets/external.hamlet")- helper "foo\n<br/>\n" $(xhamletFile "test/hamlets/external.hamlet")- helper "foo\n<br>\n" $(hamletFileReload "test/hamlets/external.hamlet")- where- foo = "foo"--caseParens :: Assertion-caseParens = do- let plus = (++)- x = "x"- y = "y"- helper "xy" [hamlet|#{(plus x) y}|]- helper "xxy" [hamlet|#{plus (plus x x) y}|]- let alist = ["1", "2", "3"]- helper "123" [hamlet|-$forall x <- (id id id id alist)- #{x}-|]--caseHamletLiterals :: Assertion-caseHamletLiterals = do- helper "123" [hamlet|#{show 123}|]- helper "123.456" [hamlet|#{show 123.456}|]- helper "-123" [hamlet|#{show -123}|]- helper "-123.456" [hamlet|#{show -123.456}|]--helper' :: String -> Html -> Assertion-helper' res h = T.pack res @=? Text.Blaze.Html.Renderer.Text.renderHtml h--caseHamlet' :: Assertion-caseHamlet' = do- helper' "foo" [shamlet|foo|]- helper' "foo" [xshamlet|foo|]- helper "<br>\n" $ const $ [shamlet|<br>|]- helper "<br/>\n" $ const $ [xshamlet|<br>|]-- -- new with generalized stuff- helper' "foo" [shamlet|foo|]- helper' "foo" [xshamlet|foo|]- helper "<br>\n" $ const $ [shamlet|<br>|]- helper "<br/>\n" $ const $ [xshamlet|<br>|]---instance Show Url where- show _ = "FIXME remove this instance show Url"--caseDiffBindNames :: Assertion-caseDiffBindNames = do- let list = words "1 2 3"- -- FIXME helper "123123" $(hamletFileReload "test/hamlets/external-debug3.hamlet")- error "test has been disabled"---caseTrailingSpaces :: Assertion-caseTrailingSpaces = helper "" [hamlet|-$if True -$elseif False -$else -$maybe x <- Nothing -$nothing -$forall x <- empty -|]- where- empty = []----caseTuple :: Assertion-caseTuple = do- helper "(1,1)" [hamlet| #{("1","1")}|]- helper "foo" [hamlet| - $with (a,b) <- ("foo","bar")- #{a}- |]- helper "url" [hamlet| - $with (a,b) <- (Home,Home)- @{a}- |]- helper "url" [hamlet| - $with p <- (Home,[])- @?{p}- |]----caseComplex :: Assertion-caseComplex = do- let z :: ((Int,Int),Maybe Int,(),Bool,[[Int]])- z = ((1,2),Just 3,(),True,[[4],[5,6]])- helper "1 2 3 4 5 61 2 3 4 5 6" [hamlet|- $with ((a,b),Just c, () ,True,d@[[e],[f,g]]) <- z- $forall h <- d- #{a} #{b} #{c} #{e} #{f} #{g}- |]--caseRecord :: Assertion-caseRecord = do- let z = ARecord 10 True- helper "10" [hamlet|- $with ARecord { field1, field2 = True } <- z- #{field1}- |]--caseRecordWildCard :: Assertion-caseRecordWildCard = do- let z = ARecord 10 True- helper "10 True" [hamlet|- $with ARecord {..} <- z- #{field1} #{field2}- |]--caseRecordWildCard1 :: Assertion-caseRecordWildCard1 = do- let z = ARecord 10 True- helper "10" [hamlet|- $with ARecord {field2 = True, ..} <- z- #{field1}- |]--caseCaseRecord :: Assertion-caseCaseRecord = do- let z = ARecord 10 True- helper "10\nTrue" [hamlet|- $case z- $of ARecord { field1, field2 = x }- #{field1}- #{x}- |]--data Msg = Hello | Goodbye--ihelper :: String -> HtmlUrlI18n Msg Url -> Assertion-ihelper res h = do- let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h showMsg render- T.pack res @=? x- where- showMsg Hello = preEscapedString "Hola"- showMsg Goodbye = preEscapedString "Adios"--instance (ToMarkup a, ToMarkup b) => ToMarkup (a,b) where- toMarkup (a,b) = do- toMarkup "("- toMarkup a- toMarkup ","- toMarkup b- toMarkup ")"
− test/Text/Shakespeare/JsSpec.hs
@@ -1,202 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} -module Text.Shakespeare.JsSpec (spec) where - -import Test.HUnit hiding (Test) -import Test.Hspec - -import Prelude hiding (reverse) -#ifdef TEST_COFFEE -import Text.Coffee -#endif -import Text.Julius -import Quoter (quote, quoteFile, quoteFileReload) -import Data.List (intercalate) -import qualified Data.Text.Lazy as T -import qualified Data.List -import qualified Data.List as L -import Data.Text (Text, pack, unpack) -import Data.Monoid (mappend) -import Data.Aeson (toJSON) - -join :: [String] -> String -#ifdef TEST_COFFEE -join l = (intercalate ";\n" l) -#else -join = intercalate "\n" -#endif - -spec :: Spec -spec = describe "shakespeare-js" $ do -#if !(defined TEST_COFFEE || defined TEST_ROY) - it "julius" $ do - let var = "x=2" - let urlp = (Home, [(pack "p", pack "q")]) - flip jelper [quote|['שלום', @{Home}, #{rawJS var}, '@?{urlp}', ^{jmixin} ]|] - $ intercalate " " - [ "['שלום'," - , "url, " ++ var ++ "," - , "'url?p=q'," - , "f(2) ]" - ] - - - it "juliusFile" $ do - let var = "x=2" - let urlp = (Home, [(pack "p", pack "q")]) - flip jelper $(quoteFile "test/juliuses/external1.julius") $ join - [ "שלום" - , var - , "url" - , "url?p=q" - , "f(2)" - ] ++ "\n" - - - it "juliusFileReload" $ do - let var = "x=2" - let urlp = (Home, [(pack "p", pack "q")]) - flip jelper $(quoteFileReload "test/juliuses/external1.julius") $ join - [ "שלום" - , var - , "url" - , "url?p=q" - , "f(2)" - ] ++ "\n" -#endif - -{- TODO - it "juliusFileDebugChange" $ do - let var = "somevar" - test result = jelper result $(juliusFileDebug "test/juliuses/external2.julius") - writeFile "test/juliuses/external2.julius" "var #{var} = 1;" - test "var somevar = 1;" - writeFile "test/juliuses/external2.julius" "var #{var} = 2;" - test "var somevar = 2;" - writeFile "test/juliuses/external2.julius" "var #{var} = 1;" - -} - - - it "julius module names" $ - let foo = "foo" - double = 3.14 :: Double - int = -5 :: Int -#ifdef TEST_COFFEE - in jelper "var _this = this;\n\n(function(shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint) {\n return [shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint];\n})(oof, oof, 3.14, -5);\n" -#else -# ifdef TEST_ROY - in jelper "(function(shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint) {\n return [shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint];\n})(oof, oof, 3.14, -5);\n" -# else - in jelper "[oof, oof, 3.14, -5]" -# endif -#endif - [quote|[#{rawJS $ Data.List.reverse foo}, #{rawJS $ L.reverse foo}, #{rawJS $ show double}, #{rawJS $ show int}]|] - - --- not valid coffeescript -#if !(defined TEST_COFFEE || defined TEST_ROY) - it "single dollar at and caret" $ do - jelper "$@^" [quote|$@^|] - jelper "#{@{^{" [quote|#\{@\{^\{|] -#endif - - it "dollar operator" $ do - let val = (1 :: Int, (2 :: Int, 3 :: Int)) -#if (defined TEST_COFFEE) - jelper "var _this = this;\n\n(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] - jelper "var _this = this;\n\n(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] -#else - -# if (defined TEST_ROY) - jelper "(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] - jelper "(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] - -# else - jelper "2" [quote|#{ rawJS $ show $ fst $ snd val }|] - jelper "2" [quote|#{ rawJS $ show $ fst $ snd $ val}|] -# endif -#endif - -#if (defined TEST_ROY) - it "roy function wrapper" $ do - let royInsert = rawJS "\"royInsert\"" - jelper "(function(shakespeare_var_royInsert) {\n var roy = {\n \"royInsert\": shakespeare_var_royInsert\n };\n return console.log(roy);\n})(\"royInsert\");\n" [quote| -let roy = { royInsert: #{royInsert} } -console.log roy -|] -#endif - it "empty file" $ jelper "" [quote||] - - it "JSON data" $ jelper "\"Hello \\\"World!\\\"\"" [julius|#{toJSON "Hello \"World!\""}|] - - it "< escaping" $ jelper "\"\\u003c\"" [julius|#{toJSON "<"}|] - - it "> escaping" $ jelper "\"\\u003e\"" [julius|#{toJSON ">"}|] - - it "& escaping" $ jelper "\"\\u0026\"" [julius|#{toJSON "&"}|] - - it "boolean interpolation" $ jelper - "true false true false true false" - [julius|#{True} #{False} #{toJSON True} #{toJSON False} #{rawJS True} #{rawJS False}|] - - it "^\\ should not be escaped" $ jelper - "var re = /[^\\r]/;" - [julius|var re = /[^\r]/;|] - - it "^\\{ should be escaped" $ jelper - "var re = /[^{]/;" - [julius|var re = /[^\{]/;|] - - -data Url = Home | Sub SubUrl -data SubUrl = SubUrl -render :: Url -> [(Text, Text)] -> Text -render Home qs = pack "url" `mappend` showParams qs -render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs - -showParams :: [(Text, Text)] -> Text -showParams [] = pack "" -showParams z = - pack $ '?' : intercalate "&" (map go z) - where - go (x, y) = go' x ++ '=' : go' y - go' = concatMap encodeUrlChar . unpack - --- | 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] - - - - -#ifndef TEST_ROY -jmixin :: JavascriptUrl u -jmixin = [quote|f(2)|] -#endif - -jelper :: String -> JavascriptUrl Url -> Assertion -jelper res h = do - T.pack res @=? renderJavascriptUrl render h - -instance Show Url where - show _ = "FIXME remove this instance show Url"
test/Text/Shakespeare/TextSpec.hs view
@@ -16,7 +16,6 @@ spec :: Spec spec = do - describe "shakespeare-text" $ do it "text" $ do let var = "var" let urlp = (Home, [(pack "p", pack "q")])