diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -102,15 +102,22 @@ unIdent (Ident s) = s bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)]) -bindingPattern (BindVar i@(Ident s)) = do +bindingPattern (BindVar i@(Ident s) (Just b)) = do name <- newName s + (pattern, scope) <- bindingPattern b + return (AsP name pattern, (i, VarE name):scope) +bindingPattern (BindVar i@(Ident s) Nothing) = do + name <- newName s return (VarP name, [(i, VarE name)]) bindingPattern (BindTuple is) = do - names <- mapM (newName . unIdent) is - return (TupP $ map VarP names, zip is $ map VarE names) + (patterns, scopes) <- fmap unzip $ mapM bindingPattern is + return (TupP patterns, concat scopes) +bindingPattern (BindList is) = do + (patterns, scopes) <- fmap unzip $ mapM bindingPattern is + return (ListP patterns, concat scopes) bindingPattern (BindConstr (Ident con) is) = do - names <- mapM (newName . unIdent) is - return (ConP (mkName con) (map VarP names), zip is $ map VarE names) + (patterns, scopes) <- fmap unzip $ mapM bindingPattern is + return (ConP (mkName con) patterns, concat scopes) docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp docToExp env hr scope (DocForall list idents inside) = do @@ -291,7 +298,7 @@ hr <- qhr case parseDoc set s of Error s' -> error s' - Ok (mnl, d) -> hrWithEnv hr $ \env -> docsToExp env hr [] d + Ok (_mnl, d) -> 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 @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Text.Hamlet.Parse ( Result (..) @@ -18,6 +19,7 @@ import Control.Applicative ((<$>), Applicative (..)) import Control.Monad import Control.Arrow +import Data.Char (isUpper) import Data.Data import Text.ParserCombinators.Parsec hiding (Line) import Data.Set (Set) @@ -297,20 +299,60 @@ tag'' (TagAttribs s) (x, y, z, as) = (x, y, z, s : as) ident :: Parser Ident - ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'') + ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'') "identifier" + parens = between (char '(' >> white) (char ')' >> white) + + brackets = between (char '[' >> white) (char ']' >> white) + + comma = char ',' >> white + + atsign = char '@' >> white + + white = skipMany $ char ' ' + + isVariable (Ident (x:_)) = not (isUpper x) + isVariable (Ident []) = error "isVariable: bad identifier" + + isConstructor (Ident (x:_)) = isUpper x + isConstructor (Ident []) = error "isConstructor: bad identifier" + identPattern :: Parser Binding - identPattern = (between - (char '(' >> spaces) - (spaces >> char ')' >> spaces) - (BindTuple <$> sepBy1 ident (spaces >> char ',' >> spaces)) - ) <|> (do - i <- ident - is <- many $ try $ (many $ char ' ') >> ident - if null is - then return $ BindVar i - else return $ BindConstr i is - ) + identPattern = + do c <- gcon + xs <- many apat + return $ BindConstr c xs + <|> apat + where + apat = varpat + <|> fmap (\c -> BindConstr c []) gcon + <|> parens tuplepat + <|> brackets listpat + + varpat = do + v <- try $ do v <- ident + guard (isVariable v) + return v + white + mb <- optionMaybe (atsign >> apat) + return (BindVar v mb) + "variable" + + gcon = try (do + c <- ident + guard (isConstructor c) + white + return c) + "constructor" + + tuplepat = do + xs <- identPattern `sepBy` comma + return $ case xs of + [x] -> x + _ -> BindTuple xs + + listpat = BindList <$> identPattern `sepBy` comma + angle = do _ <- char '<' name' <- many $ noneOf " \t.#\r\n!>" @@ -582,7 +624,7 @@ , ("strict", "") ] -data Binding = BindVar Ident | BindConstr Ident [Ident] | BindTuple [Ident] +data Binding = BindVar Ident (Maybe Binding) | BindConstr Ident [Binding] | BindTuple [Binding] | BindList [Binding] deriving (Eq, Show, Read, Data, Typeable) spaceTabs :: Parser String diff --git a/Text/Hamlet/RT.hs b/Text/Hamlet/RT.hs --- a/Text/Hamlet/RT.hs +++ b/Text/Hamlet/RT.hs @@ -66,12 +66,16 @@ Error s' -> failure $ HamletParseException s' Ok (_, x) -> liftM HamletRT $ mapM convert x where - convert x@(DocForall deref (BindVar (Ident ident)) docs) = do + convert x@(DocForall deref (BindVar _ (Just _)) docs) = + error "Runtime Hamlet does not currently support 'as' patterns" + convert x@(DocForall deref (BindVar (Ident ident) Nothing) docs) = do deref' <- flattenDeref' x deref docs' <- mapM convert docs return $ SDForall deref' ident docs' convert DocForall{} = error "Runtime Hamlet does not currently support tuple patterns" - convert x@(DocMaybe deref (BindVar (Ident ident)) jdocs ndocs) = do + convert x@(DocMaybe deref (BindVar _ (Just _)) jdocs ndocs) = + error "Runtime Hamlet does not currently support 'as' patterns" + convert x@(DocMaybe deref (BindVar (Ident ident) Nothing) jdocs ndocs) = do deref' <- flattenDeref' x deref jdocs' <- mapM convert jdocs ndocs' <- maybe (return []) (mapM convert) ndocs diff --git a/hamlet.cabal b/hamlet.cabal --- a/hamlet.cabal +++ b/hamlet.cabal @@ -1,5 +1,5 @@ name: hamlet -version: 1.1.3.1 +version: 1.1.4 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/test/HamletTest.hs b/test/HamletTest.hs --- a/test/HamletTest.hs +++ b/test/HamletTest.hs @@ -74,6 +74,7 @@ it "hamlet literals" caseHamletLiterals it "hamlet' and xhamlet'" caseHamlet' it "hamlet tuple" caseTuple + it "complex pattern" caseComplex @@ -930,6 +931,18 @@ $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} + |] data Msg = Hello | Goodbye