[better pattern matching
mail@stefanwehr.de**20050609081546] {
hunk ./Interpreter.hs 24
+import Maybe ( isJust, fromJust )
hunk ./Interpreter.hs 53
-extendEnv' :: [ValId] -> [Value] -> Env -> Env
-extendEnv' ids vs env = 
-    foldr (\ (k,v) m -> Map.insert k v m) env (zip ids vs)
+extendEnv' :: [(ValId, Value)] -> Env -> Env
+extendEnv' assocs env = 
+    foldr (\ (k,v) m -> Map.insert k v m) env assocs
hunk ./Interpreter.hs 70
-data Closure = Closure Env [ValId] Exp
+data Closure = Closure Env [Pat] Exp
hunk ./Interpreter.hs 115
-            if not (null (vbind_params b))
+            if not (null (vbind_pats b))
hunk ./Interpreter.hs 196
-             do {-
-                let allVars = freeVars e2
-                    allKeys = Map.keys env
-                    diff = allVars List.\\ allKeys
-                if not (null diff)
-                   then panic ("about to construct inconsistent thunk\n" ++
-                               showPpr e ++ "\n" ++ showCommaListed diff)
-                   else return ()
-                -}
-                let fenv' = extendEnv p (ThunkVal env e2) fenv
-                if null ps -- saturated application
-                   then eval fenv' f
-                   else return $ ClosVal (Closure fenv' ps f)
+             do l <- matchPattern p (ThunkVal env e2)
+                case l of
+                  Nothing -> phasefail ("pattern match failure")
+                  Just binds -> 
+                      let fenv' = extendEnv' binds fenv
+                          in if null ps -- saturated application
+                                then eval fenv' f
+                                else return $ ClosVal (Closure fenv' ps f)
hunk ./Interpreter.hs 215
-eval env (Lam vs e) = 
+eval env (Lam pats e) = 
hunk ./Interpreter.hs 217
-       return $ ClosVal (Closure env vs e)
+       return $ ClosVal (Closure env pats e)
hunk ./Interpreter.hs 249
-        params = map vbind_params binds
+        pats = map vbind_pats binds
hunk ./Interpreter.hs 251
-        args = map (\ (ps, e') -> Lam ps (Letrec binds e')) (zip params es)
-        lambda = Lam bindIds e
+        args = map (\ (ps, e') -> Lam ps (Letrec binds e')) (zip pats es)
+        lambda = Lam (map PVar bindIds) e
hunk ./Interpreter.hs 259
-       v <- evalStrict env e
-       case v of
-         DataVal did vs ->
-             let alt = findAlt did alts
-                 env' = extendEnv' (alt_params alt) vs env
-                 in eval env' (alt_exp alt)
+       v <- eval env e
+       (binds, exp) <- findAlt v alts
+       eval (extendEnv' binds env) exp
hunk ./Interpreter.hs 263
-          findAlt did (a:as) | alt_name a == did = a
-                             | otherwise = findAlt did as
+          findAlt v (a:as) = 
+              do l <- matchPattern (alt_pat a) v
+                 case l of
+                   Just x -> return (x, alt_exp a)
+                   Nothing -> findAlt v as
hunk ./Interpreter.hs 292
-                      eval (extendEnv' ks vs env) e'
+                      eval (extendEnv' (zip ks vs) env) e'
hunk ./Interpreter.hs 305
+
+matchPattern :: Pat -> Value -> ST (Maybe [(ValId, Value)])
+matchPattern (PAs i p) v =
+    do x <- matchPattern p v
+       case x of
+         Nothing -> return Nothing
+         Just l -> return $ Just ((i, v) : l)
+matchPattern PWildcard v = return $ Just []
+matchPattern (PVar x) v = return $ Just $ [(x, v)]
+matchPattern (PCon id pats) v = 
+    do v' <- forceThunk v
+       case v' of
+         DataVal id' vs | id == id' && length pats == length vs
+               -> do l <- mapM (uncurry matchPattern) (zip pats vs)
+                     if all isJust l
+                        then return $ Just $ concatMap fromJust l
+                        else return Nothing
+         _ -> return Nothing
hunk ./Lexer.x 71
-$small     = [a-z \xdf-\xf6 \xf8-\xff \_]
-$alpha     = [$small $large]
+$small     = [a-z \xdf-\xf6 \xf8-\xff]
+$small_    = [a-z \xdf-\xf6 \xf8-\xff \_]
+$alpha     = [$small_ $large]
hunk ./Lexer.x 75
-$graphic   = [$small $large $symbol $digit $special \:\"\']
+$graphic   = [$small_ $large $symbol $digit $special \:\"\']
hunk ./Lexer.x 83
-@varid      = $small $idchar*
+@varid      = $small $idchar* | $small_ $idchar+
hunk ./Lexer.x 109
-    ".." | ":" | "::" | "=" | ":=" | \\ | "|" | "<-" | "->" | "@" | "~" | "=>" | "-"
+    ".." | ":" | "::" | "=" | ":=" | \\ | "|" | "<-" | "->" | "@" | "~" | "=>" | "-" | "@" | "_"
hunk ./Overloading.hs 123
-       return (Lam ds (Overloading $ 
-                       Dictionary (instanceMapping ++ concat superMapping)))
+       return (Lam (map PVar ds) 
+               (Overloading $ 
+                Dictionary (instanceMapping ++ concat superMapping)))
hunk ./Overloading.hs 130
-             mapping = zip ctxParams (vbind_params bind)
-             restParams = drop n (vbind_params bind)
+             mapping = zip ctxParams (map fromPVar (vbind_pats bind))
+             restParams = drop n (vbind_pats bind)
hunk ./Overloading.hs 134
+        where fromPVar (PVar i) = i
+              fromPVar p = panic ("dictionary parameter cannot be a pattern: "
+                                  ++ showPpr' p)
hunk ./Overloading.hs 252
-type Bind = ([ValId] {- arguments -} , Exp)
+type Bind = ([Pat] {- arguments -} , Exp)
hunk ./Overloading.hs 259
-resolveOverloading subst recMap (params, e) cs =
+resolveOverloading subst recMap (pats, e) cs =
hunk ./Overloading.hs 264
-       return (ds ++ params, e')
+       return (map PVar ds ++ pats, e')
hunk ./ParseSyntax.hs 387
-    | Lam [ValId] Exp              -- abstraction: \x.e
+    | Lam [Pat] Exp                -- abstraction: \x.e
hunk ./ParseSyntax.hs 404
-                         vbind_params :: [ValId],
+                         vbind_pats :: [Pat],
hunk ./ParseSyntax.hs 410
-data Alt = Alt { alt_name :: DataId,
-                 alt_params ::[ValId],
+data Alt = Alt { alt_pat :: Pat,
hunk ./ParseSyntax.hs 415
+data Pat = PVar ValId
+         | PWildcard
+         | PCon DataId [Pat]
+         | PAs ValId Pat
+           deriving (Read,Show,Eq, Gen.Data, Gen.Typeable)
+           
hunk ./ParseSyntax.hs 572
-    ppr (ValBind x Nothing vars e _) = 
-        ppr x <+> hsep (map ppr vars) <=> ppr e
-    ppr (ValBind x (Just ty) vars e _) = 
+    ppr (ValBind x Nothing pats e _) = 
+        ppr x <+> hsep (map ppr pats) <=> ppr e
+    ppr (ValBind x (Just ty) pats e _) = 
hunk ./ParseSyntax.hs 576
-              ppr x <+> hsep (map ppr vars) <=> ppr e]
+              ppr x <+> hsep (map ppr pats) <=> ppr e]
hunk ./ParseSyntax.hs 579
-    ppr (Alt tag xs e) = ppr tag <+> hsep (map ppr xs) <->> ppr e <> semi
+    ppr (Alt pat e) = ppr pat <->> ppr e <> semi
hunk ./ParseSyntax.hs 581
-
+instance Pretty Pat where
+    ppr PWildcard = text "_"
+    ppr (PVar id) = ppr id
+    ppr (PAs id pat) = ppr id <> text "@" <> pprPrec maxPrec pat
+    ppr (PCon id pats) = 
+        parens `usedWhen` (not (null pats)) $
+        hsep (ppr id : map ppr pats)
+        
hunk ./ParseSyntax.hs 627
-        if not (null xs) then char '\\' <> (hsep (map ppr xs)) <->> ppr e
-        else pprPrec prec e
+        if not (null xs) 
+           then char '\\' <> (hsep (map (pprPrec maxPrec) xs)) <->> ppr e
+           else pprPrec prec e
hunk ./Parser.y 4
--- 
+--                      Stefan Wehr - http://www.stefanwehr.de
+--
hunk ./Parser.y 49
+
+
+-- Conflicts
+-- %expect 0
+
hunk ./Parser.y 80
+    '_'         { T _ (ReservedOpT "_") }
+    '@'         { T _ (ReservedOpT "@")   }
hunk ./Parser.y 194
-    : var vars '=' exp              { ValBind $1 Nothing $2 $4 
+    : var epats '=' exp             { ValBind $1 Nothing (reverse $2) $4 
hunk ./Parser.y 204
-    : var '::' qualifiedType ';' var vars '=' exp  
+    : var '::' qualifiedType ';' var epats '=' exp  
hunk ./Parser.y 206
-         then ValBind $1 (Just (TypeScheme [{-fill later-}] $3)) $6 $8 emptyInfo
+         then ValBind $1 (Just (TypeScheme [{-fill later-}] $3)) 
+                (reverse $6) $8 emptyInfo
hunk ./Parser.y 211
-    | var vars '=' exp                { ValBind $1 Nothing  $2 $4 emptyInfo }
+    | var epats '=' exp                { ValBind $1 Nothing (reverse $2) 
+                                          $4 emptyInfo }
hunk ./Parser.y 229
-    : '\\' var vars '->' exp            { Lam ($2:reverse $3) $5     }
+    : '\\' pats '->' exp                { Lam (reverse $2) $4     }
hunk ./Parser.y 264
-     : con vars '->' exp ';' { Alt $1 $2 $4 }
+     : pat_ '->' exp ';' { Alt $1 $3 }
+
+
+epats :: { [Pat] }
+epats : pats        { $1 }
+     | {-epsilon-}  { [] }
+
+pats :: { [Pat] }
+pats : pats pat        { $2 : $1 }
+     | pat             { [$1] }
+
+pat  :: { Pat }
+     : var                  { PVar $1 }
+     | '_'                  { PWildcard }
+     | '(' con pats ')'     { PCon $2 (reverse $3) }
+     | con                  { PCon $1 [] }
+     | '(' pat ')'          { $2 }
+     | var '@' pat          { PAs $1 $3 }
+     | '(' pat ',' pat ')'  { PCon (fst pairDataConstructor) [$2, $4] }
+
+pat_  :: { Pat }
+     : var                  { PVar $1 }
+     | '_'                  { PWildcard }
+     | con epats            { PCon $1 (reverse $2) }
+     | '(' pat ')'          { $2 }
+     | var '@' pat          { PAs $1 $3 }
+     | '(' pat ',' pat ')'  { PCon (fst pairDataConstructor) [$2, $4] }
hunk ./Parser.y 324
-
-vars :: { [Id] }
-    : vars var                  { $1 ++ [$2] } -- hmmm
-    | {-epsilon-}               { [] }
hunk ./ParserHelper.hs 58
-                                         phasefail "illegal class declaration"
+                                         phasefail ("illegal class declaration"
+                                                    ++ showPpr' t)
hunk ./ParserHelper.hs 108
+
+
hunk ./SyntaxTransformation.hs 159
-          rw_classBind (ValBind id Nothing params exp info) =
+          rw_classBind (ValBind id Nothing pats exp info) =
hunk ./SyntaxTransformation.hs 162
-                 params' <- mapM defineValVar params
+                 pats' <- mapM rw_pattern pats
hunk ./SyntaxTransformation.hs 165
-                 return (AS.ValBind uid Nothing params' exp' (rw_info info))
+                 return (AS.ValBind uid Nothing pats' exp' (rw_info info))
+
+rw_pattern :: Pat -> NA AS.Pat
+rw_pattern (PVar v) = 
+    do v' <- defineValVar v
+       return (AS.PVar v')
+rw_pattern p@(PCon id ps) = 
+    do (id', arity, _) <- lookUpDataCon id
+       if length ps /= arity
+          then phasefail ("illegal pattern " ++ showPpr' p ++ 
+                          ". Data constructor " ++ showPpr' id ++ 
+                          " takes " ++ show arity ++ " arguments, given: " ++
+                          show (length ps))
+          else return ()
+       ps' <- mapM rw_pattern ps
+       return (AS.PCon id' ps')
+rw_pattern (PAs id pat) = 
+    do pat' <- rw_pattern pat
+       id' <- defineValVar id
+       return (AS.PAs id' pat')
+rw_pattern PWildcard = return AS.PWildcard
hunk ./SyntaxTransformation.hs 302
-        else return (AS.Lam vs con)
+        else return (AS.Lam (map AS.PVar vs) con)
hunk ./SyntaxTransformation.hs 313
-rwExp (Lam vs e) = 
+rwExp (Lam pats e) = 
hunk ./SyntaxTransformation.hs 315
-     vs' <- mapM defineValVar vs
+     pats' <- mapM rw_pattern pats
hunk ./SyntaxTransformation.hs 318
-     return (AS.Lam vs' e')
+     return (AS.Lam pats' e')
hunk ./SyntaxTransformation.hs 331
-      rwAlt (Alt tg ids e) = 
-        do (tg', arity, _) <- lookUpDataCon tg
-           if arity /= length ids
-              then phasefail ("wrong number of arguments for data " ++
-                              "constructor `" ++ showPpr tg ++ "' in case "
-                              ++ " expression")
-              else return ()
-           enterBlock
-           ids' <- mapM defineValVar ids
+      rwAlt (Alt pat e) = 
+        do enterBlock
+           pat' <- rw_pattern pat
hunk ./SyntaxTransformation.hs 336
-           return (AS.Alt tg' ids' e') 
+           return (AS.Alt pat' e') 
hunk ./SyntaxTransformation.hs 358
-type BindTuple = (Maybe AS.TypeScheme, [AS.ValId], AS.Exp, AS.Info)
+type BindTuple = (Maybe AS.TypeScheme, [AS.Pat], AS.Exp, AS.Info)
hunk ./SyntaxTransformation.hs 361
-mkBind (name, (ty, params, e, info)) = AS.ValBind name ty params e info
+mkBind (name, (ty, pats, e, info)) = AS.ValBind name ty pats e info
hunk ./SyntaxTransformation.hs 367
-rw_bind (ValBind _ Nothing args e info)   = 
+rw_bind (ValBind _ Nothing pats e info)   = 
hunk ./SyntaxTransformation.hs 369
-      args' <- mapM defineValVar args
+      pats' <- mapM rw_pattern pats
hunk ./SyntaxTransformation.hs 372
-      return (Nothing, args', e', rw_info info)
-rw_bind (ValBind _ (Just ty) args e info) = 
+      return (Nothing, pats', e', rw_info info)
+rw_bind (ValBind _ (Just ty) pats e info) = 
hunk ./SyntaxTransformation.hs 375
-      args' <- mapM defineValVar args
+      pats' <- mapM rw_pattern pats
hunk ./SyntaxTransformation.hs 379
-      return ((Just ty'), args', e', rw_info info)
+      return ((Just ty'), pats', e', rw_info info)
hunk ./TypeInference.hs 58
+singleton :: ValId -> TypeScheme -> Assumps
+singleton v sc = add v sc emptyAssumps
+
hunk ./TypeInference.hs 123
+tiPats :: [Pat] -> TI ([Constraint], Assumps, [Type])
+tiPats ps = 
+    do l <- mapM tiPat ps
+       let (pss, ass, ts) = unzip3 l
+       return (concat pss, foldr merge emptyAssumps ass, ts)
+
+tiPat :: Pat -> TI ([Constraint], Assumps, Type)
+tiPat PWildcard =
+    do alpha <- lift $ freshTypeVar KindStar
+       return ([], emptyAssumps, alpha)
+tiPat (PVar i) =
+    do alpha <- lift $ freshTypeVar KindStar
+       return ([], singleton i (toScheme alpha), alpha)
+tiPat (PAs i p) =
+    do (ps, as, t) <- tiPat p
+       return (ps, add i (toScheme t) as, t)
+tiPat (PCon i ps) = 
+    do (ps, as, ts) <- tiPats ps
+       alpha <- lift $ freshTypeVar KindStar
+       sc <- liftST $ typeOfDataConstructor i
+       (qs, t) <- freshInst sc
+       ecs <- unify [] t (tyFuns ts alpha)
+       return (map EC ecs ++ ps ++ qs, as, alpha)
+    
hunk ./TypeInference.hs 202
-    do alpha <- liftST $ freshTypeVar KindStar
-       let as' = add x (toScheme alpha) as
-       (ps, tau, e') <- tiExpr as' (Lam xs e)
-       return (ps, alpha `tyFun` tau, Lam [x] e')
+    do (ps, as', t) <- tiPat x
+       (qs, tau, e') <- tiExpr (as' `merge` as) (Lam xs e)
+       return (ps ++ qs, t `tyFun` tau, Lam [x] e')
hunk ./TypeInference.hs 224
-       l <- mapM (\ (Alt di params _) -> tiPat di params) alts
-       let (pss, ts, ass) = unzip3 l
+       l <- mapM (\ (Alt pat _) -> tiPat pat) alts
+       let (pss, ass, ts) = unzip3 l
hunk ./TypeInference.hs 235
-    where
-    tiPat :: DataId -> [ValId] -> TI ([Constraint], Type, Assumps)
-    tiPat di paramIds = 
-        do ts <- liftST $ mapM (\_ -> freshTypeVar KindStar) paramIds
-           t' <- liftST $ freshTypeVar KindStar
-           sc <- liftST $ typeOfDataConstructor di
-           (qs, t) <- freshInst sc
-           ps <- unify [] t (tyFuns ts t')
-           return (map EC ps ++ qs, t', buildAssumps paramIds (map toScheme ts))
hunk ./TypeInference.hs 237
+-- tiBind is tiAlt in THIH
hunk ./TypeInference.hs 239
-tiBind as (is, e) = 
-    do alphas <- mapM (\_ -> liftST $ freshTypeVar KindStar) is
-       let ts = map toScheme alphas
-           as' = buildAssumps is ts
+tiBind as (pats, e) = 
+    do (ps, as', ts) <- tiPats pats
hunk ./TypeInference.hs 242
-       let resTy = tyFuns alphas t
-       return (qs, resTy, (is, e'))
+       let resTy = tyFuns ts t
+       return (ps ++ qs, resTy, (pats, e'))
hunk ./TypeInference.hs 413
-                let (params, e) = fromJust (lookup (vbind_name vb) bs)
-                    in vb { vbind_exp = e, vbind_params = params }
+                let (pats, e) = fromJust (lookup (vbind_name vb) bs)
+                    in vb { vbind_exp = e, vbind_pats = pats }
hunk ./TypeInference.hs 458
-          checkMethod as ci bind@(ValBind i _ params e _) =
+          checkMethod as ci bind@(ValBind i _ pats e _) =
hunk ./TypeInference.hs 473
-                 (ps, (_, _, (params', e'))) <- tiExpl as (i, sc', (params, e))
-                 let bind' = bind { vbind_params = params',
+                 (ps, (_, _, (pats', e'))) <- tiExpl as (i, sc', (pats, e))
+                 let bind' = bind { vbind_pats = pats',
}