diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -65,40 +65,42 @@ unIdent :: Ident -> String unIdent (Ident s) = s +bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)]) +bindingPattern (BindVar i@(Ident s)) = 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) +bindingPattern (BindConstr (Ident con) is) = do + names <- mapM (newName . unIdent) is + return (ConP (mkName con) (map VarP names), zip is $ map VarE names) + docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp docToExp env hr scope (DocForall list idents inside) = do let list' = derefToExp scope list - names <- mapM (newName . unIdent) idents - let pairs = zip idents (map VarE names) - let scope' = pairs ++ scope + (pat, extraScope) <- bindingPattern idents + let scope' = extraScope ++ scope mh <- [|F.mapM_|] inside' <- docsToExp env hr scope' inside - let lam = flip LamE inside' $ case names of - [x] -> [VarP x] - _ -> [TupP $ map VarP names] + let lam = LamE [pat] inside' 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, idents):dis) inside) = do let deref' = derefToExp scope deref - names <- mapM (newName . unIdent) idents - let pairs = zip idents (map VarE names) - let scope' = pairs ++ scope + (pat, extraScope) <- bindingPattern idents + let scope' = extraScope ++ scope inside' <- docToExp env hr scope' (DocWith dis inside) - let lam = flip LamE inside' $ case names of - [x] -> [VarP x] - _ -> [TupP $ map VarP names] + let lam = LamE [pat] inside' return $ lam `AppE` deref' docToExp env hr scope (DocMaybe val idents inside mno) = do let val' = derefToExp scope val - names <- mapM (newName . unIdent) idents - let pairs = zip idents (map VarE names) - let scope' = pairs ++ scope + (pat, extraScope) <- bindingPattern idents + let scope' = extraScope ++ scope inside' <- docsToExp env hr scope' inside - let inside'' = flip LamE inside' $ case names of - [x] -> [VarP x] - _ -> [TupP $ map VarP names] + let inside'' = LamE [pat] inside' ninside' <- case mno of Nothing -> [|Nothing|] Just no -> do diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -10,6 +10,7 @@ , xhtmlHamletSettings , debugHamletSettings , CloseStyle (..) + , Binding (..) ) where @@ -43,12 +44,12 @@ | ContentMsg Deref deriving (Show, Eq, Read, Data, Typeable) -data Line = LineForall Deref [Ident] +data Line = LineForall Deref Binding | LineIf Deref | LineElseIf Deref | LineElse - | LineWith [(Deref, [Ident])] - | LineMaybe Deref [Ident] + | LineWith [(Deref, Binding)] + | LineMaybe Deref Binding | LineNothing | LineCase Deref | LineOf [Ident] @@ -247,12 +248,18 @@ ident :: Parser Ident ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'') - identPattern :: Parser [Ident] + identPattern :: Parser Binding identPattern = (between (char '(' >> spaces) (spaces >> char ')' >> spaces) - (sepBy1 ident (spaces >> char ',' >> spaces)) - ) <|> (return <$> ident) + (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 + ) angle = do _ <- char '<' name' <- many $ noneOf " \t.#\r\n!>" @@ -280,10 +287,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 Binding [Doc] + | DocWith [(Deref, Binding)] [Doc] | DocCond [(Deref, [Doc])] (Maybe [Doc]) - | DocMaybe Deref [Ident] [Doc] (Maybe [Doc]) + | DocMaybe Deref Binding [Doc] (Maybe [Doc]) | DocCase Deref [([Ident], [Doc])] | DocContent Content deriving (Show, Eq, Read, Data, Typeable) @@ -506,3 +513,6 @@ , ("1.1", "") , ("strict", "") ] + +data Binding = BindVar Ident | BindConstr Ident [Ident] | BindTuple [Ident] + deriving (Eq, Show, Read, Data, Typeable) diff --git a/Text/Hamlet/RT.hs b/Text/Hamlet/RT.hs --- a/Text/Hamlet/RT.hs +++ b/Text/Hamlet/RT.hs @@ -60,12 +60,12 @@ 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 (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 [Ident ident] 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: 0.10.6 +version: 0.10.7 license: BSD3 license-file: LICENSE author: Michael Snoyman diff --git a/test/HamletTest.hs b/test/HamletTest.hs --- a/test/HamletTest.hs +++ b/test/HamletTest.hs @@ -305,7 +305,34 @@
$of Home |] + + , it "pattern-match constructors: forall" $ do + let people = [Pair "Michael" 26, Pair "Miriam" 25] + helper "
Michael
26
Miriam
25
" [hamlet| +
+ $forall Pair name age <- people +
#{name} +
#{show age} +|] + , it "pattern-match constructors: maybe" $ do + let people = Just $ Pair "Michael" 26 + helper "
Michael
26
" [hamlet| +
+ $maybe Pair name age <- people +
#{name} +
#{show age} +|] + , it "pattern-match constructors: with" $ do + let people = Pair "Michael" 26 + helper "
Michael
26
" [hamlet| +
+ $with Pair name age <- people +
#{name} +
#{show age} +|] ] + +data Pair = Pair String Int data Url = Home | Sub SubUrl data SubUrl = SubUrl