diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -28,6 +28,7 @@ , ToAttributes (..) -- * Internal, for making more , HamletSettings (..) + , NewlineStyle (..) , hamletWithSettings , hamletFileWithSettings , defaultHamletSettings @@ -46,12 +47,8 @@ import Data.Maybe (fromMaybe) import Data.Text (Text, pack) import qualified Data.Text.Lazy as TL -#if MIN_VERSION_blaze_html(0,5,0) import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Internal (preEscapedText) -#else -import Text.Blaze (Html, preEscapedText, toHtml) -#endif import qualified Data.Foldable as F import Control.Monad (mplus) import Data.Monoid (mempty, mappend) @@ -218,11 +215,6 @@ hamlet :: QuasiQuoter hamlet = hamletWithSettings hamletRules defaultHamletSettings --- | A variant which adds newlines to the output. Useful for debugging --- but may alter browser page layout. -hamlet' :: QuasiQuoter -hamlet' = hamletWithSettings hamletRules defaultHamletSettings{hamletNewlines=True} - xhamlet :: QuasiQuoter xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings @@ -286,7 +278,11 @@ hr <- qhr case parseDoc set s of Error s' -> error s' - Ok d -> hrWithEnv hr $ \env -> docsToExp env hr [] d + Ok (mnl, d) -> do + case (mnl, hamletNewlines set) of + (Nothing, DefaultNewlineStyle) -> qReport False "Warning: default newline style has changed, using an explicit $newline is recommended" + _ -> return () + hrWithEnv hr $ \env -> docsToExp env hr [] d hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp hamletFileWithSettings qhr set fp = do diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -8,9 +8,9 @@ , HamletSettings (..) , defaultHamletSettings , xhtmlHamletSettings - , debugHamletSettings , CloseStyle (..) , Binding (..) + , NewlineStyle (..) ) where @@ -60,16 +60,39 @@ , _lineContent :: [Content] , _lineClasses :: [(Maybe Deref, [Content])] , _lineAttrs :: [Deref] + , _lineNoNewline :: Bool } - | LineContent [Content] + | LineContent [Content] Bool -- ^ True == avoid newlines deriving (Eq, Show, Read) -parseLines :: HamletSettings -> String -> Result [(Int, Line)] +parseLines :: HamletSettings -> String -> Result (Maybe NewlineStyle, HamletSettings, [(Int, Line)]) parseLines set s = - case parse (many $ parseLine set) s s of + case parse parser s s of Left e -> Error $ show e Right x -> Ok x + where + parser = do + mnewline <- parseNewline + let set' = + case mnewline of + Nothing -> + case hamletNewlines set of + DefaultNewlineStyle -> set { hamletNewlines = AlwaysNewlines } + _ -> set + Just n -> set { hamletNewlines = n } + res <- many (parseLine set') + return (mnewline, set', res) + parseNewline = + (try (many eol' >> string "$newline ") >> parseNewline' >>= \nl -> eol' >> return nl) <|> + return Nothing + parseNewline' = + (try (string "always") >> return (Just AlwaysNewlines)) <|> + (try (string "never") >> return (Just NoNewlines)) <|> + (try (string "text") >> return (Just NewlinesText)) + + eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) + parseLine :: HamletSettings -> Parser (Int, Line) parseLine set = do ss <- fmap sum $ many ((char ' ' >> return 1) <|> @@ -78,6 +101,7 @@ doctypeDollar <|> comment <|> htmlComment <|> + doctypeRaw <|> backslash <|> controlIf <|> controlElseIf <|> @@ -90,13 +114,13 @@ controlOf <|> angle <|> invalidDollar <|> - (eol' >> return (LineContent [])) <|> + (eol' >> return (LineContent [] True)) <|> (do - cs <- content InContent + (cs, avoidNewLines) <- content InContent isEof <- (eof >> return True) <|> return False if null cs && ss == 0 && isEof then fail "End of Hamlet template" - else return $ LineContent cs) + else return $ LineContent cs avoidNewLines) return (ss, x) where eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) @@ -104,15 +128,21 @@ spaceTabs = many $ oneOf " \t" doctype = do try $ string "!!!" >> eol - return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] + return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] True doctypeDollar = do _ <- try $ string "$doctype " name <- many $ noneOf "\r\n" eol - case lookup name doctypeNames of + case lookup name $ hamletDoctypeNames set of Nothing -> fail $ "Unknown doctype name: " ++ name - Just val -> return $ LineContent [ContentRaw $ val ++ "\n"] + Just val -> return $ LineContent [ContentRaw $ val ++ "\n"] True + doctypeRaw = do + x <- try $ string "" x <- many nonComments eol - return $ LineContent [ContentRaw $ concat x] -- FIXME handle variables? + return $ LineContent [ContentRaw $ concat x] False {- FIXME -} -- FIXME handle variables? nonComments = (many1 $ noneOf "\r\n<") <|> (do _ <- char '<' (do @@ -135,8 +165,8 @@ return "") <|> return "<") backslash = do _ <- char '\\' - (eol >> return (LineContent [ContentRaw "\n"])) - <|> (LineContent <$> content InContent) + (eol >> return (LineContent [ContentRaw "\n"] True)) + <|> (uncurry LineContent <$> content InContent) controlIf = do _ <- try $ string "$if" spaces @@ -197,41 +227,42 @@ NotInQuotes -> return () NotInQuotesAttr -> return () InContent -> eol - return $ cc x + return (cc $ map fst x, or $ map snd x) where cc [] = [] cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c cc (a:b) = a : cc b content' cr = contentHash <|> contentAt <|> contentCaret <|> contentUnder - <|> contentReg cr + <|> contentReg' cr contentHash = do x <- parseHash case x of - Left str -> return $ ContentRaw str - Right deref -> return $ ContentVar deref + Left str -> return (ContentRaw str, null str) + Right deref -> return (ContentVar deref, False) contentAt = do x <- parseAt return $ case x of - Left str -> ContentRaw str - Right (s, y) -> ContentUrl y s + Left str -> (ContentRaw str, null str) + Right (s, y) -> (ContentUrl y s, False) contentCaret = do x <- parseCaret case x of - Left str -> return $ ContentRaw str - Right deref -> return $ ContentEmbed deref + Left str -> return (ContentRaw str, null str) + Right deref -> return (ContentEmbed deref, False) contentUnder = do x <- parseUnder case x of - Left str -> return $ ContentRaw str - Right deref -> return $ ContentMsg deref + Left str -> return (ContentRaw str, null str) + Right deref -> return (ContentMsg deref, False) + contentReg' x = (flip (,) False) <$> contentReg x contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n" contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>" contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>" contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\\\"\n\r" tagAttribValue notInQuotes = do cr <- (char '"' >> return InQuotes) <|> return notInQuotes - content cr + fst <$> content cr tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes tagCond = do d <- between (char ':') (char ':') parseDeref @@ -277,11 +308,11 @@ (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrs <|> tagAttrib Nothing)) _ <- many $ oneOf " \t\r\n" _ <- char '>' - c <- content InContent + (c, avoidNewLines) <- content InContent let (tn, attr, classes, attrsd) = tag' $ TagName name : xs if '/' `elem` tn then fail "A tag name may not contain a slash. Perhaps you have a closing tag in your HTML." - else return $ LineTag tn attr c classes attrsd + else return $ LineTag tn attr c classes attrsd avoidNewLines data TagPiece = TagName String | TagIdent [Content] @@ -341,7 +372,7 @@ cases <- mapM getOf inside rest' <- nestToDoc set rest Ok $ DocCase d cases : rest' -nestToDoc set (Nest (LineTag tn attrs content classes attrsD) inside:rest) = do +nestToDoc set (Nest (LineTag tn attrs content classes attrsD avoidNewLine) inside:rest) = do let attrFix (x, y, z) = (x, y, [(Nothing, z)]) let takeClass (a, "class", b) = Just (a, fromMaybe [] b) takeClass _ = Nothing @@ -367,24 +398,28 @@ start = DocContent $ ContentRaw $ "<" ++ tn attrs'' = concatMap attrToContent attrs' newline' = DocContent $ ContentRaw - $ if hamletNewlines set then "\n" else "" + $ case hamletNewlines set of { AlwaysNewlines | not avoidNewLine -> "\n"; _ -> "" } inside' <- nestToDoc set inside rest' <- nestToDoc set rest Ok $ start : attrs'' ++ map (DocContent . ContentAttrs) attrsD ++ seal - : newline' : map DocContent content ++ inside' ++ end : newline' : rest' -nestToDoc set (Nest (LineContent content) inside:rest) = do +nestToDoc set (Nest (LineContent content avoidNewLine) inside:rest) = do inside' <- nestToDoc set inside rest' <- nestToDoc set rest let newline' = DocContent $ ContentRaw - $ if hamletNewlines set then "\n" else "" + $ case hamletNewlines set of { NoNewlines -> ""; _ -> if nextIsContent && not avoidNewLine then "\n" else "" } + nextIsContent = + case (inside, rest) of + ([], Nest LineContent{} _:_) -> True + ([], Nest LineTag{} _:_) -> True + _ -> False Ok $ map DocContent content ++ newline':inside' ++ rest' nestToDoc _set (Nest (LineElseIf _) _:_) = Error "Unexpected elseif" nestToDoc _set (Nest LineElse _:_) = Error "Unexpected else" @@ -414,14 +449,14 @@ ) = compressDoc $ (DocContent $ ContentRaw $ x ++ y) : rest compressDoc (DocContent x:rest) = DocContent x : compressDoc rest -parseDoc :: HamletSettings -> String -> Result [Doc] +parseDoc :: HamletSettings -> String -> Result (Maybe NewlineStyle, [Doc]) parseDoc set s = do - ls <- parseLines set s - let notEmpty (_, LineContent []) = False + (mnl, set', ls) <- parseLines set s + let notEmpty (_, LineContent [] _) = False notEmpty _ = True let ns = nestLines $ filter notEmpty ls - ds <- nestToDoc set ns - return $ compressDoc ds + ds <- nestToDoc set' ns + return (mnl, compressDoc ds) attrToContent :: (Maybe Deref, String, [(Maybe Deref, Maybe [Content])]) -> [Doc] attrToContent (Just cond, k, v) = @@ -459,12 +494,20 @@ hamletDoctype :: String -- | Should we add newlines to the output, making it more human-readable? -- Useful for client-side debugging but may alter browser page layout. - , hamletNewlines :: Bool + , hamletNewlines :: NewlineStyle -- | How a tag should be closed. Use this to switch between HTML, XHTML -- or even XML output. , hamletCloseStyle :: String -> CloseStyle + -- | Mapping from short names in \"$doctype\" statements to full doctype. + , hamletDoctypeNames :: [(String, String)] } +data NewlineStyle = NoNewlines -- ^ never add newlines + | NewlinesText -- ^ add newlines between consecutive text lines + | AlwaysNewlines -- ^ add newlines everywhere + | DefaultNewlineStyle + deriving Show + htmlEmptyTags :: Set String htmlEmptyTags = Set.fromAscList [ "area" @@ -484,18 +527,15 @@ -- | Defaults settings: HTML5 doctype and HTML-style empty tags. defaultHamletSettings :: HamletSettings -defaultHamletSettings = HamletSettings "" False htmlCloseStyle +defaultHamletSettings = HamletSettings "" DefaultNewlineStyle htmlCloseStyle doctypeNames xhtmlHamletSettings :: HamletSettings xhtmlHamletSettings = - HamletSettings doctype False xhtmlCloseStyle + HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames where doctype = "" - -debugHamletSettings :: HamletSettings -debugHamletSettings = HamletSettings "" True htmlCloseStyle htmlCloseStyle :: String -> CloseStyle htmlCloseStyle s = diff --git a/Text/Hamlet/RT.hs b/Text/Hamlet/RT.hs --- a/Text/Hamlet/RT.hs +++ b/Text/Hamlet/RT.hs @@ -64,7 +64,7 @@ parseHamletRT set s = case parseDoc set s of Error s' -> failure $ HamletParseException s' - Ok x -> liftM HamletRT $ mapM convert x + Ok (_, x) -> liftM HamletRT $ mapM convert x where convert x@(DocForall deref (BindVar (Ident ident)) docs) = do deref' <- flattenDeref' x deref diff --git a/hamlet.cabal b/hamlet.cabal --- a/hamlet.cabal +++ b/hamlet.cabal @@ -1,5 +1,5 @@ name: hamlet -version: 1.0.1.4 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -39,13 +39,9 @@ test/tmp.hs test.hs -flag blaze_html_0_5 - description: Use blaze-html 0.5 and blaze-markup 0.5 - default: True - library build-depends: base >= 4 && < 5 - , shakespeare >= 1.0 && < 1.1 + , shakespeare >= 1.0.1 && < 1.1 , bytestring >= 0.9 , template-haskell , parsec >= 2 && < 4 @@ -54,14 +50,8 @@ , containers >= 0.2 , blaze-builder >= 0.2 && < 0.4 , process >= 1.0 && < 1.2 - - if flag(blaze_html_0_5) - build-depends: - blaze-html >= 0.5 && < 0.6 + , blaze-html >= 0.5 && < 0.6 , blaze-markup >= 0.5.1 && < 0.6 - else - build-depends: - blaze-html >= 0.4 && < 0.5 exposed-modules: Text.Hamlet Text.Hamlet.RT @@ -82,7 +72,7 @@ , containers >= 0.2 && < 0.5 , text >= 0.7 && < 1 , HUnit - , hspec >= 1.0 && < 1.2 + , hspec >= 1.2 && < 1.3 , blaze-html >= 0.5 && < 0.6 , blaze-markup >= 0.5.1 && < 0.6 diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -1,5 +1,5 @@ import HamletTest (specs) -import Test.Hspec +import Test.Hspec.Core main :: IO () -main = hspecX [specs] +main = hspec [specs] diff --git a/test/HamletTest.hs b/test/HamletTest.hs --- a/test/HamletTest.hs +++ b/test/HamletTest.hs @@ -3,7 +3,7 @@ module HamletTest (specs) where import Test.HUnit hiding (Test) -import Test.Hspec +import Test.Hspec.Core import Test.Hspec.HUnit import Prelude hiding (reverse) @@ -14,11 +14,12 @@ import qualified Data.List as L import qualified Data.Map as Map import Data.Text (Text, pack, unpack) -import Data.Monoid (mappend) +import Data.Monoid (mappend,mconcat) 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 specs = describe "hamlet" [ it "empty" caseEmpty @@ -72,6 +73,7 @@ , it "parens" caseParens , it "hamlet literals" caseHamletLiterals , it "hamlet' and xhamlet'" caseHamlet' + , it "hamlet tuple" caseTuple @@ -83,7 +85,7 @@ , it "ignores a blank line" $ do - helper "

foo

" [hamlet| + helper "

foo

\n" [hamlet|

foo @@ -94,9 +96,10 @@ - , it "hamlet angle bracket syntax" $ + , it "angle bracket syntax" $ helper "

HELLO

" [hamlet| +$newline never HELLO |] @@ -106,7 +109,9 @@ , it "hamlet module names" $ let foo = "foo" in helper "oof oof 3.14 -5" - [hamlet|#{Data.List.reverse foo} # + [hamlet| +$newline never +#{Data.List.reverse foo} # #{L.reverse foo} # #{show 3.14} #{show -5}|] @@ -157,6 +162,7 @@ , it "HTML comments" $ do helper "

1

2 not ignored

" [hamlet| +$newline never

1

@@ -192,13 +198,13 @@ , it "conditional class" $ do - helper "

" + helper "

\n" [hamlet|

|] - helper "

" + helper "

\n" [hamlet|

|] - helper "

" + helper "

\n" [hamlet|

|] @@ -214,31 +220,32 @@ , it "non-poly HTML" $ do - helperHtml "

HELLO WORLD

" [shamlet| + helperHtml "

HELLO WORLD

\n" [shamlet|

HELLO WORLD |] - helperHtml "

HELLO WORLD

" $(shamletFile "test/hamlets/nonpolyhtml.hamlet") + helperHtml "

HELLO WORLD

\n" $(shamletFile "test/hamlets/nonpolyhtml.hamlet") , it "non-poly Hamlet" $ do let embed = [hamlet|

EMBEDDED|] - helper "

url

EMBEDDED

" [hamlet| + helper "

url

\n

EMBEDDED

\n" [hamlet|

@{Home} ^{embed} |] - helper "

url

" $(hamletFile "test/hamlets/nonpolyhamlet.hamlet") + helper "

url

\n" $(hamletFile "test/hamlets/nonpolyhamlet.hamlet") , it "non-poly IHamlet" $ do let embed = [ihamlet|

EMBEDDED|] - ihelper "

Adios

EMBEDDED

" [ihamlet| + ihelper "

Adios

\n

EMBEDDED

\n" [ihamlet|

_{Goodbye} ^{embed} |] - ihelper "

Hola

" $(ihamletFile "test/hamlets/nonpolyihamlet.hamlet") + ihelper "

Hola

\n" $(ihamletFile "test/hamlets/nonpolyihamlet.hamlet") , it "pattern-match tuples: forall" $ do let people = [("Michael", 26), ("Miriam", 25)] helper "
Michael
26
Miriam
25
" [hamlet| +$newline never
$forall (name, age) <- people
#{name} @@ -247,6 +254,7 @@ , it "pattern-match tuples: maybe" $ do let people = Just ("Michael", 26) helper "
Michael
26
" [hamlet| +$newline never
$maybe (name, age) <- people
#{name} @@ -255,6 +263,7 @@ , it "pattern-match tuples: with" $ do let people = ("Michael", 26) helper "
Michael
26
" [hamlet| +$newline never
$with (name, age) <- people
#{name} @@ -262,17 +271,17 @@ |] , it "list syntax for interpolation" $ do helper "
  • 1
  • 2
  • 3
" [hamlet| +$newline never
    $forall num <- [1, 2, 3]
  • #{show num} |] -{- , it "infix operators" $ helper "5" [hamlet|#{show $ (4 + 5) - (2 + 2)}|] , it "infix operators with parens" $ - helper "5" [hamlet|#{show (2 + 3)}|] - -} + helper "5" [hamlet|#{show ((+) 1 1 + 3)}|] , it "doctypes" $ helper "\n\n" [hamlet| +$newline never $doctype 5 $doctype strict |] @@ -281,6 +290,7 @@ let nothing = Nothing justTrue = Just True in helper "



    " [hamlet| +$newline never $case nothing $of Just val $of Nothing @@ -304,7 +314,8 @@ , it "case on Url" $ let url1 = Home url2 = Sub SubUrl - in helper "

    " [hamlet| + in helper "
    \n
    \n" [hamlet| +$newline always $case url1 $of Home
    @@ -320,6 +331,7 @@ , it "pattern-match constructors: forall" $ do let people = [Pair "Michael" 26, Pair "Miriam" 25] helper "
    Michael
    26
    Miriam
    25
    " [hamlet| +$newline text
    $forall Pair name age <- people
    #{name} @@ -328,6 +340,7 @@ , it "pattern-match constructors: maybe" $ do let people = Just $ Pair "Michael" 26 helper "
    Michael
    26
    " [hamlet| +$newline text
    $maybe Pair name age <- people
    #{name} @@ -336,6 +349,7 @@ , it "pattern-match constructors: with" $ do let people = Pair "Michael" 26 helper "
    Michael
    26
    " [hamlet| +$newline text
    $with Pair name age <- people
    #{name} @@ -343,21 +357,56 @@ |] , it "multiline tags" $ helper - "content" [hamlet| + "content\n" [hamlet| content |] , let attrs = [("bar", "baz"), ("bin", "<>\"&")] in it "*{...} attributes" $ helper - "content" [hamlet| + "content\n" [hamlet| content |] , it "blank attr values" $ helper - "" + "\n" [hamlet||] , it "greater than in attr" $ helper - "" + "\n" [hamlet|