diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -102,11 +102,11 @@ unIdent (Ident s) = s bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)]) -bindingPattern (BindVar i@(Ident s) (Just b)) = do +bindingPattern (BindAs i@(Ident s) b) = do name <- newName s (pattern, scope) <- bindingPattern b return (AsP name pattern, (i, VarE name):scope) -bindingPattern (BindVar i@(Ident s) Nothing) = do +bindingPattern (BindVar i@(Ident s)) = do name <- newName s return (VarP name, [(i, VarE name)]) bindingPattern (BindTuple is) = do @@ -118,6 +118,12 @@ bindingPattern (BindConstr (Ident con) is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is return (ConP (mkName con) patterns, concat scopes) +bindingPattern (BindRecord (Ident con) fields) = do + let f (Ident field,b) = + do (p,s) <- bindingPattern b + return ((mkName field,p),s) + (patterns, scopes) <- fmap unzip $ mapM f fields + return (RecP (mkName con) patterns, concat scopes) docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp docToExp env hr scope (DocForall list idents inside) = do diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -299,16 +299,24 @@ tag'' (TagAttribs s) (x, y, z, as) = (x, y, z, s : as) ident :: Parser Ident - ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'') "identifier" + ident = do + i <- many1 (alphaNum <|> char '_' <|> char '\'') + white + return (Ident i) + "identifier" parens = between (char '(' >> white) (char ')' >> white) brackets = between (char '[' >> white) (char ']' >> white) + braces = between (char '{' >> white) (char '}' >> white) + comma = char ',' >> white atsign = char '@' >> white + equals = char '=' >> white + white = skipMany $ char ' ' isVariable (Ident (x:_)) = not (isUpper x) @@ -318,33 +326,43 @@ isConstructor (Ident []) = error "isConstructor: bad identifier" identPattern :: Parser Binding - identPattern = - do c <- gcon - xs <- many apat - return $ BindConstr c xs - <|> apat + identPattern = gcon True <|> apat where - apat = varpat - <|> fmap (\c -> BindConstr c []) gcon - <|> parens tuplepat - <|> brackets listpat + apat = choice + [ varpat + , gcon False + , 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) + option (BindVar v) $ do + atsign + b <- apat + return (BindAs v b) "variable" - gcon = try (do - c <- ident - guard (isConstructor c) - white - return c) + gcon :: Bool -> Parser Binding + gcon allowArgs = do + c <- try $ do c <- ident + guard (isConstructor c) + return c + choice + [ fmap (BindRecord c) (braces (recordField `sepBy` comma)) + , fmap (BindConstr c) (guard allowArgs >> many apat) + , return (BindConstr c []) + ] "constructor" + recordField = do + field <- ident + p <- option (BindVar field) -- support punning + (equals >> identPattern) + return (field,p) + tuplepat = do xs <- identPattern `sepBy` comma return $ case xs of @@ -624,7 +642,9 @@ , ("strict", "") ] -data Binding = BindVar Ident (Maybe Binding) | BindConstr Ident [Binding] | BindTuple [Binding] | BindList [Binding] +data Binding = BindVar Ident | BindAs Ident Binding | BindConstr Ident [Binding] + | BindTuple [Binding] | BindList [Binding] + | BindRecord Ident [(Ident, 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,16 +66,16 @@ Error s' -> failure $ HamletParseException s' Ok (_, x) -> liftM HamletRT $ mapM convert x where - convert x@(DocForall deref (BindVar _ (Just _)) docs) = + convert x@(DocForall deref (BindAs _ _) docs) = error "Runtime Hamlet does not currently support 'as' patterns" - convert x@(DocForall deref (BindVar (Ident ident) Nothing) docs) = do + convert x@(DocForall deref (BindVar (Ident ident)) 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 _ (Just _)) jdocs ndocs) = + convert x@(DocMaybe deref (BindAs _ _) jdocs ndocs) = error "Runtime Hamlet does not currently support 'as' patterns" - convert x@(DocMaybe deref (BindVar (Ident ident) Nothing) jdocs ndocs) = do + convert x@(DocMaybe deref (BindVar (Ident ident)) 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.4 +version: 1.1.5 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 @@ -75,6 +75,7 @@ it "hamlet' and xhamlet'" caseHamlet' it "hamlet tuple" caseTuple it "complex pattern" caseComplex + it "record pattern" caseRecord @@ -942,6 +943,16 @@ $with ((a,b),Just c, () ,True,d@[[e],[f,g]]) <- z $forall h <- d #{a} #{b} #{c} #{e} #{f} #{g} + |] + +data ARecord = ARecCon { field1 :: Int, field2 :: Bool } + +caseRecord :: Assertion +caseRecord = do + let z = ARecCon 10 True + helper "10" [hamlet| + $with ARecCon { field1, field2 = True } <- z + #{field1} |] data Msg = Hello | Goodbye