diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -43,6 +43,7 @@ import qualified Data.Text.Lazy as TL import Text.Blaze (Html, preEscapedText, toHtml) import qualified Data.Foldable as F +import Control.Monad (mplus) type Render url = url -> [(Text, Text)] -> Text type Translate msg = msg -> Html @@ -61,31 +62,43 @@ [x] -> return x _ -> return $ DoE $ map NoBindS exps +unIdent :: Ident -> String +unIdent (Ident s) = s + docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp -docToExp env hr scope (DocForall list ident@(Ident name) inside) = do +docToExp env hr scope (DocForall list idents inside) = do let list' = derefToExp scope list - name' <- newName name - let scope' = (ident, VarE name') : scope + names <- mapM (newName . unIdent) idents + let pairs = zip idents (map VarE names) + let scope' = pairs ++ scope mh <- [|F.mapM_|] inside' <- docsToExp env hr scope' inside - let lam = LamE [VarP name'] inside' + let lam = flip LamE inside' $ case names of + [x] -> [VarP x] + _ -> [TupP $ map VarP names] return $ mh `AppE` lam `AppE` list' docToExp env hr scope (DocWith [] inside) = do inside' <- docsToExp env hr scope inside return $ inside' -docToExp env hr scope (DocWith ((deref,ident@(Ident name)):dis) inside) = do +docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do let deref' = derefToExp scope deref - name' <- newName name - let scope' = (ident, VarE name') : scope + names <- mapM (newName . unIdent) idents + let pairs = zip idents (map VarE names) + let scope' = pairs ++ scope inside' <- docToExp env hr scope' (DocWith dis inside) - let lam = LamE [VarP name'] inside' + let lam = flip LamE inside' $ case names of + [x] -> [VarP x] + _ -> [TupP $ map VarP names] return $ lam `AppE` deref' -docToExp env hr scope (DocMaybe val ident@(Ident name) inside mno) = do +docToExp env hr scope (DocMaybe val idents inside mno) = do let val' = derefToExp scope val - name' <- newName name - let scope' = (ident, VarE name') : scope + names <- mapM (newName . unIdent) idents + let pairs = zip idents (map VarE names) + let scope' = pairs ++ scope inside' <- docsToExp env hr scope' inside - let inside'' = LamE [VarP name'] inside' + let inside'' = flip LamE inside' $ case names of + [x] -> [VarP x] + _ -> [TupP $ map VarP names] ninside' <- case mno of Nothing -> [|Nothing|] Just no -> do @@ -253,14 +266,9 @@ -- first is performed. In there are no true values, then the second argument is -- performed, if supplied. condH :: Monad m => [(Bool, m ())] -> Maybe (m ()) -> m () -condH [] Nothing = return () -condH [] (Just x) = x -condH ((True, y):_) _ = y -condH ((False, _):rest) z = condH rest z +condH bms mm = fromMaybe (return ()) $ lookup True bms `mplus` mm -- | Runs the second argument with the value in the first, if available. -- Otherwise, runs the third argument, if available. maybeH :: Monad m => Maybe v -> (v -> m ()) -> Maybe (m ()) -> m () -maybeH Nothing _ Nothing = return () -maybeH Nothing _ (Just x) = x -maybeH (Just v) f _ = f v +maybeH mv f mm = fromMaybe (return ()) $ fmap f mv `mplus` mm diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -43,12 +43,12 @@ | ContentMsg Deref deriving (Show, Eq, Read, Data, Typeable) -data Line = LineForall Deref Ident +data Line = LineForall Deref [Ident] | LineIf Deref | LineElseIf Deref | LineElse - | LineWith [(Deref, Ident)] - | LineMaybe Deref Ident + | LineWith [(Deref, [Ident])] + | LineMaybe Deref [Ident] | LineNothing | LineTag { _lineTagName :: String @@ -132,7 +132,7 @@ eol return $ LineElseIf x binding = do - y <- ident + y <- identPattern spaces _ <- string "<-" spaces @@ -201,24 +201,28 @@ content cr tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes tagCond = do - _ <- char ':' - d <- parseDeref - _ <- char ':' + d <- between (char ':') (char ':') parseDeref tagClass (Just d) <|> tagAttrib (Just d) tagClass x = char '.' >> (TagClass . (,) x) <$> tagAttribValue NotInQuotes tagAttrib cond = do s <- many1 $ noneOf " \t=\r\n>" - v <- (do - _ <- char '=' - s' <- tagAttribValue NotInQuotesAttr - return s') <|> return [] + v <- (char '=' >> tagAttribValue NotInQuotesAttr) <|> return [] return $ TagAttrib (cond, s, v) tag' = foldr tag'' ("div", [], []) tag'' (TagName s) (_, y, z) = (s, y, z) tag'' (TagIdent s) (x, y, z) = (x, (Nothing, "id", s) : y, z) tag'' (TagClass s) (x, y, z) = (x, y, s : z) tag'' (TagAttrib s) (x, y, z) = (x, s : y, z) + + ident :: Parser Ident ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'') + + identPattern :: Parser [Ident] + identPattern = (between + (char '(' >> spaces) + (spaces >> char ')' >> spaces) + (sepBy1 ident (spaces >> char ',' >> spaces)) + ) <|> (return <$> ident) angle = do _ <- char '<' name' <- many $ noneOf " \t.#\r\n!>" @@ -226,10 +230,7 @@ xs <- many $ try ((many $ oneOf " \t") >> (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrib Nothing)) _ <- many $ oneOf " \t" - c <- (eol >> return []) <|> (do - _ <- char '>' - c <- content InContent - return c) + c <- (eol >> return []) <|> (char '>' >> content InContent) let (tn, attr, classes) = tag' $ TagName name : xs return $ LineTag tn attr c classes @@ -249,10 +250,10 @@ let (deeper, rest') = span (\(i', _) -> i' > i) rest in Nest l (nestLines deeper) : nestLines rest' -data Doc = DocForall Deref Ident [Doc] - | DocWith [(Deref,Ident)] [Doc] +data Doc = DocForall Deref [Ident] [Doc] + | DocWith [(Deref, [Ident])] [Doc] | DocCond [(Deref, [Doc])] (Maybe [Doc]) - | DocMaybe Deref Ident [Doc] (Maybe [Doc]) + | DocMaybe Deref [Ident] [Doc] (Maybe [Doc]) | DocContent Content deriving (Show, Eq, Read, Data, Typeable) @@ -367,7 +368,7 @@ ++ [DocContent $ ContentRaw "\""] attrToContent (Nothing, k, v) = -- only for class DocContent (ContentRaw (' ' : k ++ "=\"")) - : concat (map go $ init v) + : concatMap go (init v) ++ go' (last v) ++ [DocContent $ ContentRaw "\""] where @@ -450,7 +451,7 @@ -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest]) parseConds set front (Nest LineElse inside:rest) = do inside' <- nestToDoc set inside - Ok $ (front [], Just inside', rest) + Ok (front [], Just inside', rest) parseConds set front (Nest (LineElseIf d) inside:rest) = do inside' <- nestToDoc set inside parseConds set (front . (:) (d, inside')) rest diff --git a/Text/Hamlet/RT.hs b/Text/Hamlet/RT.hs --- a/Text/Hamlet/RT.hs +++ b/Text/Hamlet/RT.hs @@ -60,15 +60,17 @@ Error s' -> failure $ HamletParseException s' Ok x -> liftM HamletRT $ mapM convert x where - convert x@(DocForall deref (Ident ident) docs) = do + convert x@(DocForall deref [Ident ident] docs) = do deref' <- flattenDeref' x deref docs' <- mapM convert docs return $ SDForall deref' ident docs' - convert x@(DocMaybe deref (Ident ident) jdocs ndocs) = do + convert DocForall{} = error "Runtime Hamlet does not currently support tuple patterns" + convert x@(DocMaybe deref [Ident ident] jdocs ndocs) = do deref' <- flattenDeref' x deref jdocs' <- mapM convert jdocs ndocs' <- maybe (return []) (mapM convert) ndocs return $ SDMaybe deref' ident jdocs' ndocs' + convert DocMaybe{} = error "Runtime Hamlet does not currently support tuple patterns" convert (DocContent (ContentRaw s')) = return $ SDRaw s' convert x@(DocContent (ContentVar deref)) = do y <- flattenDeref' x deref diff --git a/hamlet.cabal b/hamlet.cabal --- a/hamlet.cabal +++ b/hamlet.cabal @@ -1,5 +1,5 @@ name: hamlet -version: 0.10.3 +version: 0.10.4 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -8,7 +8,7 @@ description: Hamlet gives you a type-safe tool for generating HTML code. It works via Quasi-Quoting, and generating extremely efficient output code. The syntax is white-space sensitive, and it helps you avoid cross-site scripting issues and 404 errors. Please see the documentation at for more details. . - Here is a quick overview of hamlet html. Due to haddock escaping issues, we can't properly show variable insertion, but we are still going to show some conditionals. Please see http://www.yesodweb.com/book/templates for a thorough description + Here is a quick overview of hamlet html. Due to haddock escaping issues, we can't properly show variable insertion, but we are still going to show some conditionals. Please see for a thorough description . > !!! > @@ -40,7 +40,7 @@ library build-depends: base >= 4 && < 5 - , shakespeare >= 0.10 && < 0.11 + , shakespeare >= 0.10.2 && < 0.11 , bytestring >= 0.9 && < 0.10 , template-haskell , blaze-html >= 0.4 && < 0.5 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -226,6 +226,39 @@ ^{embed} |] ihelper "

Hola

" $(ihamletFile "test/nonpolyihamlet.hamlet") + + , it "pattern-match tuples: forall" $ do + let people = [("Michael", 26), ("Miriam", 25)] + helper "
Michael
26
Miriam
25
" [hamlet| +
+ $forall (name, age) <- people +
#{name} +
#{show age} +|] + , it "pattern-match tuples: maybe" $ do + let people = Just ("Michael", 26) + helper "
Michael
26
" [hamlet| +
+ $maybe (name, age) <- people +
#{name} +
#{show age} +|] + , it "pattern-match tuples: with" $ do + let people = ("Michael", 26) + helper "
Michael
26
" [hamlet| +
+ $with (name, age) <- people +
#{name} +
#{show age} +|] + , it "list syntax for interpolation" $ do + helper "
  • 1
  • 2
  • 3
" [hamlet| +
    + $forall num <- [1, 2, 3] +
  • #{show num} +|] + , it "infix operators" $ + helper "5" [hamlet|#{show $ (4 + 5) - (2 + 2)}|] ] data Url = Home | Sub SubUrl