(F)SLIT -> (f)sLit in Match
[ghc.git] / compiler / deSugar / Match.lhs
index ca18706..f545930 100644 (file)
@@ -6,10 +6,19 @@
 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"
 
+import {-#SOURCE#-} DsExpr (dsLExpr)
+
 import DynFlags
 import HsSyn           
 import TcHsSyn
@@ -28,13 +37,13 @@ import MatchLit
 import PrelInfo
 import Type
 import TysWiredIn
-import BasicTypes
 import ListSetOps
 import SrcLoc
 import Maybes
 import Util
 import Name
 import Outputable
+import FastString
 \end{code}
 
 This function is a wrapper of @match@, it must be called from all the parts where 
@@ -51,20 +60,26 @@ matchCheck ::  DsMatchContext
             -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
             -> DsM MatchResult  -- Desugared result!
 
-matchCheck ctx vars ty qs
-   = getDOptsDs                                `thenDs` \ dflags ->
-     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
+                  -> [Id]
+                  -> Type
+                  -> [EquationInfo]
+                  -> DsM MatchResult
 matchCheck_really dflags ctx vars ty qs
-  | incomplete && shadow 
-      dsShadowWarn ctx eqns_shadow             `thenDs`   \ () ->
-      dsIncompleteWarn ctx pats                        `thenDs`   \ () ->
+  | incomplete && shadow  = do
+      dsShadowWarn ctx eqns_shadow
+      dsIncompleteWarn ctx pats
       match vars ty qs
-  | incomplete            = 
-      dsIncompleteWarn ctx pats                        `thenDs`   \ () ->
+  | incomplete            = do
+      dsIncompleteWarn ctx pats
       match vars ty qs
-  | shadow                = 
-      dsShadowWarn ctx eqns_shadow             `thenDs`   \ () ->
+  | shadow                = do
+      dsShadowWarn ctx eqns_shadow
       match vars ty qs
   | otherwise             =
       match vars ty qs
@@ -85,6 +100,7 @@ It will limit the number of patterns/equations displayed to@ maximum_output@.
 (ToDo: add command-line option?)
 
 \begin{code}
+maximum_output :: Int
 maximum_output = 4
 \end{code}
 
@@ -96,11 +112,11 @@ dsShadowWarn ctx@(DsMatchContext kind loc) qs
   = putSrcSpanDs loc (warnDs warn)
   where
     warn | qs `lengthExceeds` maximum_output
-         = pp_context ctx (ptext SLIT("are overlapped"))
+         = pp_context ctx (ptext (sLit "are overlapped"))
                      (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
-                     ptext SLIT("..."))
+                     ptext (sLit "..."))
         | otherwise
-         = pp_context ctx (ptext SLIT("are overlapped"))
+         = pp_context ctx (ptext (sLit "are overlapped"))
                      (\ f -> vcat $ map (ppr_eqn f kind) qs)
 
 
@@ -108,37 +124,42 @@ dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
 dsIncompleteWarn ctx@(DsMatchContext kind loc) pats 
   = putSrcSpanDs loc (warnDs warn)
        where
-         warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
-                           (\f -> hang (ptext SLIT("Patterns not matched:"))
+         warn = pp_context ctx (ptext (sLit "are non-exhaustive"))
+                            (\_ -> hang (ptext (sLit "Patterns not matched:"))
                                   4 ((vcat $ map (ppr_incomplete_pats kind)
                                                  (take maximum_output pats))
                                      $$ dots))
 
-         dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
+         dots | pats `lengthExceeds` maximum_output = ptext (sLit "...")
               | otherwise                           = empty
 
+pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
 pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
-  = vcat [ptext SLIT("Pattern match(es)") <+> msg,
-         sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
+  = vcat [ptext (sLit "Pattern match(es)") <+> msg,
+         sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
   where
     (ppr_match, pref)
        = case kind of
             FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
-            other        -> (pprMatchContext kind, \ pp -> pp)
+             _            -> (pprMatchContext kind, \ pp -> pp)
 
+ppr_pats :: Outputable a => [a] -> SDoc
 ppr_pats pats = sep (map ppr pats)
 
+ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
 ppr_shadow_pats kind pats
-  = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")]
-    
-ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
-ppr_incomplete_pats kind (pats,constraints) = 
-                        sep [ppr_pats pats, ptext SLIT("with"), 
+  = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]
+
+ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc
+ppr_incomplete_pats _ (pats,[]) = ppr_pats pats
+ppr_incomplete_pats _ (pats,constraints) =
+                        sep [ppr_pats pats, ptext (sLit "with"), 
                              sep (map ppr_constraint constraints)]
-    
 
-ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
+ppr_constraint :: (Name,[HsLit]) -> SDoc
+ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats]
 
+ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc
 ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
 \end{code}
 
@@ -254,7 +275,7 @@ match :: [Id]                 -- Variables rep'ing the exprs we're matching with
 
 match [] ty eqns
   = ASSERT2( not (null eqns), ppr ty )
-    returnDs (foldr1 combineMatchResults match_results)
+    return (foldr1 combineMatchResults match_results)
   where
     match_results = [ ASSERT( null (eqn_pats eqn) ) 
                      eqn_rhs eqn
@@ -267,8 +288,13 @@ match vars@(v:_) ty eqns
          (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
 
                -- Group the equations and match each group in turn
-       ; match_results <- mapM match_group (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)
+
+       ; match_results <- mapM match_group grouped
        ; return (adjustMatchResult (foldr1 (.) aux_binds) $
                  foldr1 combineMatchResults match_results) }
   where
@@ -277,39 +303,75 @@ match vars@(v:_) ty eqns
 
     match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
     match_group eqns@((group,_) : _)
-      = case group of
-         PgAny     -> matchVariables  vars ty (dropGroup eqns)
-         PgCon _   -> matchConFamily  vars ty (subGroups eqns)
-         PgLit _   -> matchLiterals   vars ty (subGroups eqns)
-         PgN lit   -> matchNPats      vars ty (subGroups eqns)
-         PgNpK lit -> matchNPlusKPats vars ty (dropGroup eqns)
-         PgBang    -> matchBangs      vars ty (dropGroup eqns)
-         PgCo _    -> matchCoercion   vars ty (dropGroup eqns)
+        = case group of
+            PgAny      -> matchVariables  vars ty (dropGroup eqns)
+            PgCon _    -> matchConFamily  vars ty (subGroups eqns)
+            PgLit _    -> matchLiterals   vars ty (subGroups eqns)
+            PgN _      -> matchNPats      vars ty (subGroups eqns)
+            PgNpK _    -> matchNPlusKPats vars ty (dropGroup eqns)
+            PgBang     -> matchBangs      vars ty (dropGroup eqns)
+            PgCo _     -> matchCoercion   vars ty (dropGroup eqns)
+            PgView _ _ -> matchView       vars ty (dropGroup eqns)
+
+    -- FIXME: we should also warn about view patterns that should be
+    -- commoned up but are not
+
+    -- print some stuff to see what's getting grouped
+    -- use -dppr-debug to see the resolution of overloaded lits
+    debug eqns = 
+        let gs = map (\group -> foldr (\ (p,_) -> \acc -> 
+                                           case p of PgView e _ -> e:acc 
+                                                     _ -> acc) [] group) eqns
+            maybeWarn [] = return ()
+            maybeWarn l = warnDs (vcat l)
+        in 
+          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
+                       (filter (not . null) gs))
 
 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 (var:vars) ty eqns = match vars ty (shiftEqns eqns)
+matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
 
 matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 matchBangs (var:vars) ty eqns
-  = do { match_result <- match (var:vars) ty (map shift eqns)
+  = do { match_result <- match (var:vars) ty (map decomposeFirst_Bang eqns)
        ; return (mkEvalMatchResult var ty match_result) }
-  where
-    shift eqn@(EqnInfo { eqn_pats = BangPat pat : pats })
-       = eqn { eqn_pats = unLoc pat : pats }
 
 matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the coercion to the match variable and then match that
-matchCoercion (var:vars) ty (eqn1:eqns)
+matchCoercion (var:vars) ty (eqns@(eqn1:_))
   = do { let CoPat co pat _ = firstPat eqn1
        ; var' <- newUniqueId (idName var) (hsPatType pat)
-       ; match_result <- match (var':vars) ty (map shift (eqn1:eqns))
+       ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns)
        ; rhs <- dsCoercion co (return (Var var))
        ; return (mkCoLetMatchResult (NonRec var' rhs) match_result) }
-  where
-    shift eqn@(EqnInfo { eqn_pats = CoPat _ pat _ : pats })
-       = eqn { eqn_pats = pat : pats }
+
+matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Apply the view function to the match variable and then match that
+matchView (var:vars) ty (eqns@(eqn1:_))
+  = do { -- we could pass in the expr from the PgView,
+         -- but this needs to extract the pat anyway 
+         -- to figure out the type of the fresh variable
+         let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
+         -- do the rest of the compilation 
+       ; var' <- newUniqueId (idName var) (hsPatType pat)
+       ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns)
+         -- compile the view expressions
+       ; viewExpr' <- dsLExpr viewExpr
+       ; return (mkViewMatchResult var' viewExpr' var match_result) }
+
+-- 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)
+
 \end{code}
 
 %************************************************************************
@@ -369,9 +431,9 @@ tidyEqnInfo :: Id -> EquationInfo
        --      NPlusKPat
        -- but no other
 
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
-  = tidy1 v pat        `thenDs` \ (wrap, pat') ->
-    returnDs (wrap, eqn { eqn_pats = pat' : pats })
+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
@@ -391,12 +453,12 @@ tidy1 :: Id                       -- The Id being scrutinised
 
 tidy1 v (ParPat pat)      = tidy1 v (unLoc pat) 
 tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) 
-tidy1 v (WildPat ty)      = returnDs (idDsWrapper, WildPat ty)
+tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)
 
        -- case v of { x -> mr[] }
        -- = case v of { _ -> let x=v in mr[] }
 tidy1 v (VarPat var)
-  = returnDs (wrapBind var v, WildPat (idType var)) 
+  = return (wrapBind var v, WildPat (idType var)) 
 
 tidy1 v (VarPatOut var binds)
   = do { prs <- dsLHsBinds binds
@@ -423,10 +485,10 @@ tidy1 v (AsPat (L _ var) pat)
 tidy1 v (LazyPat pat)
   = do { sel_prs <- mkSelectorBinds pat (Var v)
        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
-       ; returnDs (mkDsLets sel_binds, WildPat (idType v)) }
+       ; return (mkDsLets sel_binds, WildPat (idType v)) }
 
-tidy1 v (ListPat pats ty)
-  = returnDs (idDsWrapper, unLoc list_ConPat)
+tidy1 _ (ListPat pats ty)
+  = return (idDsWrapper, unLoc list_ConPat)
   where
     list_ty     = mkListTy ty
     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
@@ -435,30 +497,30 @@ tidy1 v (ListPat pats ty)
 
 -- Introduce fake parallel array constructors to be able to handle parallel
 -- arrays with the existing machinery for constructor pattern
-tidy1 v (PArrPat pats ty)
-  = returnDs (idDsWrapper, unLoc parrConPat)
+tidy1 _ (PArrPat pats ty)
+  = return (idDsWrapper, unLoc parrConPat)
   where
     arity      = length pats
     parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
 
-tidy1 v (TuplePat pats boxity ty)
-  = returnDs (idDsWrapper, unLoc tuple_ConPat)
+tidy1 _ (TuplePat pats boxity ty)
+  = return (idDsWrapper, unLoc tuple_ConPat)
   where
     arity = length pats
     tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
 
 -- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 v (LitPat lit)
-  = returnDs (idDsWrapper, tidyLitPat lit)
+tidy1 _ (LitPat lit)
+  = return (idDsWrapper, tidyLitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 v (NPat lit mb_neg eq lit_ty)
-  = returnDs (idDsWrapper, tidyNPat lit mb_neg eq lit_ty)
+tidy1 _ (NPat lit mb_neg eq)
+  = return (idDsWrapper, tidyNPat lit mb_neg eq)
 
 -- Everything else goes through unchanged...
 
-tidy1 v non_interesting_pat
-  = returnDs (idDsWrapper, non_interesting_pat)
+tidy1 _ non_interesting_pat
+  = return (idDsWrapper, non_interesting_pat)
 \end{code}
 
 \noindent
@@ -655,34 +717,32 @@ matchSimply :: CoreExpr                   -- Scrutinee
            -> CoreExpr                 -- Return this if it doesn't
            -> DsM CoreExpr
 
-matchSimply scrut hs_ctx pat result_expr fail_expr
-  = let
+matchSimply scrut hs_ctx pat result_expr fail_expr = do
+    let
       match_result = cantFailMatchResult result_expr
-      rhs_ty      = exprType fail_expr
-       -- Use exprType of fail_expr, because won't refine in the case of failure!
-    in 
-    matchSinglePat scrut hs_ctx pat rhs_ty match_result        `thenDs` \ match_result' ->
+      rhs_ty       = exprType fail_expr
+        -- Use exprType of fail_expr, because won't refine in the case of failure!
+    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
-  = getDOptsDs                         `thenDs` \ dflags ->
-    getSrcSpanDs                       `thenDs` \ locn ->
+matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result = do
+    dflags <- getDOptsDs
+    locn <- getSrcSpanDs
     let
-       match_fn dflags
+        match_fn dflags
            | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
-          | otherwise                          = match
-          where
-            ds_ctx = DsMatchContext hs_ctx locn
-    in
+           | 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
-  = selectSimpleMatchVarL pat                          `thenDs` \ var ->
-    matchSinglePat (Var var) hs_ctx pat ty match_result        `thenDs` \ match_result' ->
-    returnDs (adjustMatchResult (bindNonRec var scrut) 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}
 
 
@@ -703,7 +763,9 @@ data PatGroup
   | PgBang             -- Bang patterns
   | PgCo Type          -- Coercion patterns; the type is the type
                        --      of the pattern *inside*
-
+  | PgView (LHsExpr Id) -- view pattern (e -> p):
+                        -- the LHsExpr is the expression e
+           Type         -- the Type is the type of p (equivalently, the result type of e)
 
 groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
 -- If the result is of form [g1, g2, g3], 
@@ -735,7 +797,7 @@ sameGroup PgAny      PgAny      = True
 sameGroup PgBang     PgBang     = True
 sameGroup (PgCon _)  (PgCon _)  = True         -- One case expression
 sameGroup (PgLit _)  (PgLit _)  = True         -- One case expression
-sameGroup (PgN l1)   (PgN l2)   = True         -- Needs conditionals
+sameGroup (PgN _)    (PgN _)    = True         -- Needs conditionals
 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2       -- Order is significant
                                                -- See Note [Order of n+k]
 sameGroup (PgCo        t1)  (PgCo t2)  = t1 `coreEqType` t2
@@ -743,16 +805,102 @@ sameGroup (PgCo  t1)  (PgCo t2)  = t1 `coreEqType` t2
        -- enclosed pattern is the same. The patterns outside the CoPat
        -- always have the same type, so this boils down to saying that
        -- the two coercions are identical.
+sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) 
+       -- ViewPats are in the same gorup iff the expressions
+       -- are "equal"---conservatively, we use syntactic equality
 sameGroup _          _          = False
+
+-- an approximation of syntactic equality used for determining when view
+-- exprs are in the same group.
+-- this function can always safely return false;
+-- but doing so will result in the application of the view function being repeated.
+--
+-- currently: compare applications of literals and variables
+--            and anything else that we can do without involving other
+--            HsSyn types in the recursion
+--
+-- NB we can't assume that the two view expressions have the same type.  Consider
+--   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')
+
+        -- check that two lists have the same length
+        -- and that they match up pairwise
+        lexps [] [] = True
+        lexps [] (_:_) = False
+        lexps (_:_) [] = False
+        lexps (x:xs) (y:ys) = lexp x y && lexps 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 (WpApp d)   (WpApp d')   = d == d'
+        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'
+        -- comparing the constants seems right
+        exp (HsLit l) (HsLit 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 (HsIf e e1 e2) (HsIf e' e1' e2') =
+            lexp e e' && lexp e1 e1' && lexp e2 e2'
+        exp (ExplicitList _ ls) (ExplicitList _ ls') = lexps ls ls'
+        exp (ExplicitPArr _ ls) (ExplicitPArr _ ls') = lexps ls ls'
+        exp (ExplicitTuple ls _) (ExplicitTuple ls' _) = lexps ls ls'
+        -- Enhancement: could implement equality for more expressions
+        --   if it seems useful
+        exp _ _  = False
+    in
+      lexp e1 e2
+
 patGroup :: Pat Id -> PatGroup
 patGroup (WildPat {})                = PgAny
 patGroup (BangPat {})                = PgBang  
 patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc)
 patGroup (LitPat lit)                = PgLit (hsLitKey lit)
-patGroup (NPat olit mb_neg _ _)              = PgN   (hsOverLitKey olit (isJust mb_neg))
+patGroup (NPat olit mb_neg _)        = PgN   (hsOverLitKey olit (isJust mb_neg))
 patGroup (NPlusKPat _ olit _ _)              = PgNpK (hsOverLitKey olit False)
-patGroup (CoPat _ p _)               = PgCo  (hsPatType p)     -- Type of inner pattern
+patGroup (CoPat _ p _)               = PgCo  (hsPatType p)     -- Type of innelexp pattern
+patGroup (ViewPat expr p _)               = PgView expr (hsPatType (unLoc p))
 patGroup pat = pprPanic "patGroup" (ppr pat)
 \end{code}