Merge master into the ghc-new-co branch
[ghc.git] / compiler / deSugar / Match.lhs
index e148cf7..1a044d3 100644 (file)
@@ -6,13 +6,6 @@
 The @match@ function
 
 \begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
 
 #include "HsVersions.h"
@@ -35,17 +28,19 @@ import Id
 import DataCon
 import MatchCon
 import MatchLit
-import PrelInfo
 import Type
+import Coercion
 import TysWiredIn
 import ListSetOps
 import SrcLoc
 import Maybes
 import Util
 import Name
-import FiniteMap
 import Outputable
 import FastString
+
+import Control.Monad( when )
+import qualified Data.Map as Map
 \end{code}
 
 This function is a wrapper of @match@, it must be called from all the parts where 
@@ -62,9 +57,9 @@ matchCheck ::  DsMatchContext
             -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
             -> DsM MatchResult  -- Desugared result!
 
-matchCheck ctx vars ty qs = do
-    dflags <- getDOptsDs
-    matchCheck_really dflags ctx vars ty qs
+matchCheck ctx vars ty qs
+  = do { dflags <- getDOptsDs
+       ; matchCheck_really dflags ctx vars ty qs }
 
 matchCheck_really :: DynFlags
                   -> DsMatchContext
@@ -72,28 +67,31 @@ matchCheck_really :: DynFlags
                   -> Type
                   -> [EquationInfo]
                   -> DsM MatchResult
-matchCheck_really dflags ctx vars ty qs
-  | incomplete && shadow  = do
-      dsShadowWarn ctx eqns_shadow
-      dsIncompleteWarn ctx pats
-      match vars ty qs
-  | incomplete            = do
-      dsIncompleteWarn ctx pats
-      match vars ty qs
-  | shadow                = do
-      dsShadowWarn ctx eqns_shadow
-      match vars ty qs
-  | otherwise             =
-      match vars ty qs
-  where (pats, eqns_shadow) = check qs
-        incomplete    = want_incomplete && (notNull pats)
-        want_incomplete = case ctx of
-                              DsMatchContext RecUpd _ ->
-                                  dopt Opt_WarnIncompletePatternsRecUpd dflags
-                              _ ->
-                                  dopt Opt_WarnIncompletePatterns       dflags
-        shadow        = dopt Opt_WarnOverlappingPatterns dflags
-                       && not (null eqns_shadow)
+matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
+  = do { when shadow (dsShadowWarn ctx eqns_shadow)
+       ; when incomplete (dsIncompleteWarn ctx pats)
+       ; match vars ty qs }
+  where 
+    (pats, eqns_shadow) = check qs
+    incomplete = incomplete_flag hs_ctx && (notNull pats)
+    shadow     = dopt Opt_WarnOverlappingPatterns dflags
+                && notNull eqns_shadow
+
+    incomplete_flag :: HsMatchContext id -> Bool
+    incomplete_flag (FunRhs {})   = dopt Opt_WarnIncompletePatterns dflags
+    incomplete_flag CaseAlt       = dopt Opt_WarnIncompletePatterns dflags
+
+    incomplete_flag LambdaExpr    = dopt Opt_WarnIncompleteUniPatterns dflags
+    incomplete_flag PatBindRhs    = dopt Opt_WarnIncompleteUniPatterns dflags
+    incomplete_flag ProcExpr      = dopt Opt_WarnIncompleteUniPatterns dflags
+
+    incomplete_flag RecUpd        = dopt Opt_WarnIncompletePatternsRecUpd dflags
+
+    incomplete_flag ThPatQuote    = False
+    incomplete_flag (StmtCtxt {}) = False  -- Don't warn about incomplete patterns
+                                          -- in list comprehensions, pattern guards
+                                          -- etc.  They are often *supposed* to be
+                                          -- incomplete 
 \end{code}
 
 This variable shows the maximum number of lines of output generated for warnings.
@@ -287,13 +285,13 @@ match vars@(v:_) ty eqns
   = ASSERT( not (null eqns ) )
     do {       -- Tidy the first pattern, generating
                -- auxiliary bindings if necessary
-         (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
+          (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
 
                -- Group the equations and match each group in turn
-       ; let grouped = groupEquations tidy_eqns
+        ; let grouped = groupEquations tidy_eqns
 
          -- print the view patterns that are commoned up to help debug
-       ; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped)
+        ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
 
        ; match_results <- mapM match_group grouped
        ; return (adjustMatchResult (foldr1 (.) aux_binds) $
@@ -303,11 +301,11 @@ match vars@(v:_) ty eqns
     dropGroup = map snd
 
     match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
+    match_group [] = panic "match_group"
     match_group eqns@((group,_) : _)
         = case group of
             PgCon _    -> matchConFamily  vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
             PgLit _    -> matchLiterals   vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
-
             PgAny      -> matchVariables  vars ty (dropGroup eqns)
             PgN _      -> matchNPats      vars ty (dropGroup eqns)
             PgNpK _    -> matchNPlusKPats vars ty (dropGroup eqns)
@@ -334,21 +332,26 @@ matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Real true variables, just like in matchVar, SLPJ p 94
 -- No binding to do: they'll all be wildcards by now (done in tidy)
 matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
+matchVariables [] _ _ = panic "matchVariables"
 
 matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 matchBangs (var:vars) ty eqns
-  = do { match_result <- match (var:vars) ty (map decomposeFirst_Bang eqns)
+  = do { match_result <- match (var:vars) ty $
+                          map (decomposeFirstPat getBangPat) eqns
        ; return (mkEvalMatchResult var ty match_result) }
+matchBangs [] _ _ = panic "matchBangs"
 
 matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the coercion to the match variable and then match that
 matchCoercion (var:vars) ty (eqns@(eqn1:_))
   = do { let CoPat co pat _ = firstPat eqn1
        ; var' <- newUniqueId var (hsPatType pat)
-       ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns)
+       ; match_result <- match (var':vars) ty $
+                          map (decomposeFirstPat getCoPat) eqns
        ; co' <- dsHsWrapper co
         ; let rhs' = co' (Var var)
        ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
+matchCoercion _ _ _ = panic "matchCoercion"
 
 matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the view function to the match variable and then match that
@@ -359,22 +362,26 @@ matchView (var:vars) ty (eqns@(eqn1:_))
          let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
          -- do the rest of the compilation 
        ; var' <- newUniqueId var (hsPatType pat)
-       ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns)
+       ; match_result <- match (var':vars) ty $
+                          map (decomposeFirstPat getViewPat) eqns
          -- compile the view expressions
-       ; viewExpr' <- dsLExpr viewExpr
+        ; viewExpr' <- dsLExpr viewExpr
        ; return (mkViewMatchResult var' viewExpr' var match_result) }
+matchView _ _ _ = panic "matchView"
 
 -- decompose the first pattern and leave the rest alone
 decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
 decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
        = eqn { eqn_pats = extractpat pat : pats}
-
-decomposeFirst_Coercion, decomposeFirst_Bang, decomposeFirst_View :: EquationInfo -> EquationInfo
-
-decomposeFirst_Coercion = decomposeFirstPat (\ (CoPat _ pat _) -> pat)
-decomposeFirst_Bang     = decomposeFirstPat (\ (BangPat pat  ) -> unLoc pat)
-decomposeFirst_View     = decomposeFirstPat (\ (ViewPat _ pat _) -> unLoc pat)
-
+decomposeFirstPat _ _ = panic "decomposeFirstPat"
+
+getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id
+getCoPat (CoPat _ pat _)     = pat
+getCoPat _                   = panic "getCoPat"
+getBangPat (BangPat pat  )   = unLoc pat
+getBangPat _                 = panic "getBangPat"
+getViewPat (ViewPat _ pat _) = unLoc pat
+getViewPat _                 = panic "getBangPat"
 \end{code}
 
 %************************************************************************
@@ -434,9 +441,12 @@ tidyEqnInfo :: Id -> EquationInfo
        --      NPlusKPat
        -- but no other
 
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) = do
-    (wrap, pat') <- tidy1 v pat
-    return (wrap, eqn { eqn_pats = do pat' : pats })
+tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) 
+  = panic "tidyEqnInfo"
+
+tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
+  = do { (wrap, pat') <- tidy1 v pat
+       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
 
 tidy1 :: Id                    -- The Id being scrutinised
       -> Pat Id                -- The pattern against which it is to be matched
@@ -463,11 +473,6 @@ tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)
 tidy1 v (VarPat var)
   = return (wrapBind var v, WildPat (idType var)) 
 
-tidy1 v (VarPatOut var binds)
-  = do { ds_ev_binds <- dsTcEvBinds binds
-       ; return (wrapBind var v . wrapDsEvBinds ds_ev_binds,
-                 WildPat (idType var)) }
-
        -- case v of { x@p -> mr[] }
        -- = case v of { p -> let x=v in mr[] }
 tidy1 v (AsPat (L _ var) pat)
@@ -518,14 +523,13 @@ tidy1 _ (LitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
 tidy1 _ (NPat lit mb_neg eq)
-  = return (idDsWrapper, tidyNPat lit mb_neg eq)
+  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
 
 -- BangPatterns: Pattern matching is already strict in constructors,
 -- tuples etc, so the last case strips off the bang for thoses patterns.
 tidy1 v (BangPat (L _ (LazyPat p)))       = tidy1 v (BangPat p)
 tidy1 v (BangPat (L _ (ParPat p)))        = tidy1 v (BangPat p)
 tidy1 _ p@(BangPat (L _(VarPat _)))       = return (idDsWrapper, p)
-tidy1 _ p@(BangPat (L _(VarPatOut _ _)))  = return (idDsWrapper, p)
 tidy1 _ p@(BangPat (L _ (WildPat _)))     = return (idDsWrapper, p)
 tidy1 _ p@(BangPat (L _ (CoPat _ _ _)))   = return (idDsWrapper, p)
 tidy1 _ p@(BangPat (L _ (SigPatIn _ _)))  = return (idDsWrapper, p)
@@ -700,21 +704,14 @@ matchEquations  :: HsMatchContext Name
                -> [Id] -> [EquationInfo] -> Type
                -> DsM CoreExpr
 matchEquations ctxt vars eqns_info rhs_ty
-  = do { dflags <- getDOptsDs
-       ; locn   <- getSrcSpanDs
-       ; let   ds_ctxt      = DsMatchContext ctxt locn
+  = do { locn <- getSrcSpanDs
+       ; let   ds_ctxt   = DsMatchContext ctxt locn
                error_doc = matchContextErrString ctxt
 
-       ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+       ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info
 
        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
        ; extractMatchResult match_result fail_expr }
-  where 
-    match_fun dflags ds_ctxt
-       = case ctxt of 
-           LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
-                      | otherwise                          -> match
-           _                                               -> matchCheck ds_ctxt
 \end{code}
 
 %************************************************************************
@@ -734,7 +731,7 @@ matchSimply :: CoreExpr                     -- Scrutinee
            -> CoreExpr                 -- Return this if it matches
            -> CoreExpr                 -- Return this if it doesn't
            -> DsM CoreExpr
-
+-- Do not warn about incomplete patterns; see matchSinglePat comments
 matchSimply scrut hs_ctx pat result_expr fail_expr = do
     let
       match_result = cantFailMatchResult result_expr
@@ -743,24 +740,21 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
     match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
     extractMatchResult match_result' fail_expr
 
-
 matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
               -> Type -> MatchResult -> DsM MatchResult
-matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result = do
-    dflags <- getDOptsDs
-    locn <- getSrcSpanDs
-    let
-        match_fn dflags
-           | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
-           | otherwise                          = match
-           where
-             ds_ctx = DsMatchContext hs_ctx locn
-    match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }]
-
-matchSinglePat scrut hs_ctx pat ty match_result = do
-    var <- selectSimpleMatchVarL pat
-    match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
-    return (adjustMatchResult (bindNonRec var scrut) match_result')
+-- Do not warn about incomplete patterns
+-- Used for things like [ e | pat <- stuff ], where 
+-- incomplete patterns are just fine
+matchSinglePat (Var var) ctx (L _ pat) ty match_result 
+  = do { locn <- getSrcSpanDs
+       ; matchCheck (DsMatchContext ctx locn)
+                    [var] ty  
+                    [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }] }
+
+matchSinglePat scrut hs_ctx pat ty match_result
+  = do { var <- selectSimpleMatchVarL pat
+       ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
+       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
 \end{code}
 
 
@@ -802,14 +796,14 @@ subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
 -- Each sub-list in the result has the same PatGroup
 -- See Note [Take care with pattern order]
 subGroup group 
-    = map reverse $ eltsFM $ foldl accumulate emptyFM group
+    = map reverse $ Map.elems $ foldl accumulate Map.empty group
   where
     accumulate pg_map (pg, eqn)
-      = case lookupFM pg_map pg of
-          Just eqns -> addToFM pg_map pg (eqn:eqns)
-          Nothing   -> addToFM pg_map pg [eqn]
+      = case Map.lookup pg pg_map of
+          Just eqns -> Map.insert pg (eqn:eqns) pg_map
+          Nothing   -> Map.insert pg [eqn]      pg_map
 
-    -- pg_map :: FiniteMap a [EquationInfo]
+    -- pg_map :: Map a [EquationInfo]
     -- Equations seen so far in reverse order of appearance
 \end{code}
 
@@ -832,7 +826,7 @@ sameGroup (PgCon _)  (PgCon _)  = True              -- One case expression
 sameGroup (PgLit _)  (PgLit _)  = True         -- One case expression
 sameGroup (PgN l1)   (PgN l2)   = l1==l2       -- Order is significant
 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2       -- See Note [Grouping overloaded literal patterns]
-sameGroup (PgCo        t1)  (PgCo t2)  = t1 `coreEqType` t2
+sameGroup (PgCo        t1)  (PgCo t2)  = t1 `eqType` t2
        -- CoPats are in the same goup only if the type of the
        -- enclosed pattern is the same. The patterns outside the CoPat
        -- always have the same type, so this boils down to saying that
@@ -855,77 +849,87 @@ sameGroup _          _          = False
 --   f (e1 -> True) = ...
 --   f (e2 -> "hi") = ...
 viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
-viewLExprEq (e1,_) (e2,_) =
-    let 
-        -- short name for recursive call on unLoc
-        lexp e e' = exp (unLoc e) (unLoc e')
-
-       eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
-        eq_list _  []     []     = True
-        eq_list _  []     (_:_)  = False
-        eq_list _  (_:_)  []     = False
-        eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
-
-        -- conservative, in that it demands that wrappers be
-        -- syntactically identical and doesn't look under binders
-        --
-        -- coarser notions of equality are possible
-        -- (e.g., reassociating compositions,
-        --        equating different ways of writing a coercion)
-        wrap WpHole WpHole = True
-        wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
-        wrap (WpCast c)  (WpCast c')  = tcEqType c c'
-        wrap (WpEvApp _) (WpEvApp _) = panic "ToDo: Match.viewLExprEq"
-        wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
-        -- Enhancement: could implement equality for more wrappers
-        --   if it seems useful (lams and lets)
-        wrap _ _ = False
-
-        -- real comparison is on HsExpr's
-        -- strip parens 
-        exp (HsPar (L _ e)) e'   = exp e e'
-        exp e (HsPar (L _ e'))   = exp e e'
-        -- because the expressions do not necessarily have the same type,
-        -- we have to compare the wrappers
-        exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
-        exp (HsVar i) (HsVar i') =  i == i' 
-        -- the instance for IPName derives using the id, so this works if the
-        -- above does
-        exp (HsIPVar i) (HsIPVar i') = i == i' 
-        exp (HsOverLit l) (HsOverLit l') = 
-            -- Overloaded lits are equal if they have the same type
-            -- and the data is the same.
-            -- this is coarser than comparing the SyntaxExpr's in l and l',
-            -- which resolve the overloading (e.g., fromInteger 1),
-            -- because these expressions get written as a bunch of different variables
-            -- (presumably to improve sharing)
-            tcEqType (overLitType l) (overLitType l') && l == l'
-        exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
-        -- the fixities have been straightened out by now, so it's safe
-        -- to ignore them?
-        exp (OpApp l o _ ri) (OpApp l' o' _ ri') = 
-            lexp l l' && lexp o o' && lexp ri ri'
-        exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
-        exp (SectionL e1 e2) (SectionL e1' e2') = 
-            lexp e1 e1' && lexp e2 e2'
-        exp (SectionR e1 e2) (SectionR e1' e2') = 
-            lexp e1 e1' && lexp e2 e2'
-        exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
-            eq_list tup_arg es1 es2
-        exp (HsIf e e1 e2) (HsIf e' e1' e2') =
-            lexp e e' && lexp e1 e1' && lexp e2 e2'
-
-        -- Enhancement: could implement equality for more expressions
-        --   if it seems useful
-       -- But no need for HsLit, ExplicitList, ExplicitTuple, 
-       -- because they cannot be functions
-        exp _ _  = False
-
-        tup_arg (Present e1) (Present e2) = lexp e1 e2
-        tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2
-        tup_arg _ _ = False
-    in
-      lexp e1 e2
+viewLExprEq (e1,_) (e2,_) = lexp e1 e2
+  where
+    lexp :: LHsExpr Id -> LHsExpr Id -> Bool
+    lexp e e' = exp (unLoc e) (unLoc e')
+
+    ---------
+    exp :: HsExpr Id -> HsExpr Id -> Bool
+    -- real comparison is on HsExpr's
+    -- strip parens 
+    exp (HsPar (L _ e)) e'   = exp e e'
+    exp e (HsPar (L _ e'))   = exp e e'
+    -- because the expressions do not necessarily have the same type,
+    -- we have to compare the wrappers
+    exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
+    exp (HsVar i) (HsVar i') =  i == i' 
+    -- the instance for IPName derives using the id, so this works if the
+    -- above does
+    exp (HsIPVar i) (HsIPVar i') = i == i' 
+    exp (HsOverLit l) (HsOverLit l') = 
+        -- Overloaded lits are equal if they have the same type
+        -- and the data is the same.
+        -- this is coarser than comparing the SyntaxExpr's in l and l',
+        -- which resolve the overloading (e.g., fromInteger 1),
+        -- because these expressions get written as a bunch of different variables
+        -- (presumably to improve sharing)
+        eqType (overLitType l) (overLitType l') && l == l'
+    exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
+    -- the fixities have been straightened out by now, so it's safe
+    -- to ignore them?
+    exp (OpApp l o _ ri) (OpApp l' o' _ ri') = 
+        lexp l l' && lexp o o' && lexp ri ri'
+    exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
+    exp (SectionL e1 e2) (SectionL e1' e2') = 
+        lexp e1 e1' && lexp e2 e2'
+    exp (SectionR e1 e2) (SectionR e1' e2') = 
+        lexp e1 e1' && lexp e2 e2'
+    exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
+        eq_list tup_arg es1 es2
+    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
+        lexp e e' && lexp e1 e1' && lexp e2 e2'
+
+    -- Enhancement: could implement equality for more expressions
+    --   if it seems useful
+    -- But no need for HsLit, ExplicitList, ExplicitTuple, 
+    -- because they cannot be functions
+    exp _ _  = False
+
+    ---------
+    tup_arg (Present e1) (Present e2) = lexp e1 e2
+    tup_arg (Missing t1) (Missing t2) = eqType t1 t2
+    tup_arg _ _ = False
+
+    ---------
+    wrap :: HsWrapper -> HsWrapper -> Bool
+    -- Conservative, in that it demands that wrappers be
+    -- syntactically identical and doesn't look under binders
+    --
+    -- Coarser notions of equality are possible
+    -- (e.g., reassociating compositions,
+    --        equating different ways of writing a coercion)
+    wrap WpHole WpHole = True
+    wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
+    wrap (WpCast c)  (WpCast c')     = coreEqCoercion c c'
+    wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
+    wrap (WpTyApp t) (WpTyApp t')    = eqType t t'
+    -- Enhancement: could implement equality for more wrappers
+    --   if it seems useful (lams and lets)
+    wrap _ _ = False
+
+    ---------
+    ev_term :: EvTerm -> EvTerm -> Bool
+    ev_term (EvId a)       (EvId b)       = a==b
+    ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b
+    ev_term _ _ = False        
+
+    ---------
+    eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
+    eq_list _  []     []     = True
+    eq_list _  []     (_:_)  = False
+    eq_list _  (_:_)  []     = False
+    eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
 
 patGroup :: Pat Id -> PatGroup
 patGroup (WildPat {})                = PgAny
@@ -956,3 +960,4 @@ If the first arg matches '1' but the second does not match 'True', we
 cannot jump to the third equation!  Because the same argument might
 match '2'!
 Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
+