Merge master into the ghc-new-co branch
[ghc.git] / compiler / deSugar / Match.lhs
index 9ff1548..1a044d3 100644 (file)
@@ -1,41 +1,46 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[Main_match]{The @match@ function}
+
+The @match@ function
 
 \begin{code}
 module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
 
 #include "HsVersions.h"
 
-import DynFlags        ( DynFlag(..), dopt )
+import {-#SOURCE#-} DsExpr (dsLExpr)
+
+import DynFlags
 import HsSyn           
-import TcHsSyn         ( mkVanillaTuplePat, hsPatType )
-import Check            ( check, ExhaustivePat )
+import TcHsSyn
+import Check
 import CoreSyn
-import Literal         ( Literal )
-import CoreUtils       ( bindNonRec, exprType )
+import Literal
+import CoreUtils
+import MkCore
 import DsMonad
-import DsBinds         ( dsLHsBinds, dsCoercion )
-import DsGRHSs         ( dsGRHSs )
+import DsBinds
+import DsGRHSs
 import DsUtils
-import Id              ( idName, idType, Id )
-import DataCon         ( DataCon )
-import MatchCon                ( matchConFamily )
-import MatchLit                ( matchLiterals, matchNPlusKPats, matchNPats, 
-                         tidyLitPat, tidyNPat, hsLitKey, hsOverLitKey )
-import PrelInfo                ( pAT_ERROR_ID )
-import TcType          ( Type )
-import Type            ( splitFunTysN, coreEqType )
-import TysWiredIn      ( consDataCon, mkListTy, unitTy,
-                         tupleCon, parrFakeCon, mkPArrTy )
-import BasicTypes      ( Boxity(..) )
-import ListSetOps      ( equivClasses, runs )
-import SrcLoc          ( unLoc, Located(..) )
-import Maybes          ( isJust )
-import Util             ( lengthExceeds, notNull )
-import Name            ( Name )
+import Id
+import DataCon
+import MatchCon
+import MatchLit
+import Type
+import Coercion
+import TysWiredIn
+import ListSetOps
+import SrcLoc
+import Maybes
+import Util
+import Name
 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 
@@ -53,31 +58,40 @@ matchCheck ::  DsMatchContext
             -> DsM MatchResult  -- Desugared result!
 
 matchCheck ctx vars ty qs
-   = getDOptsDs                                `thenDs` \ dflags ->
-     matchCheck_really dflags ctx vars ty qs
-
-matchCheck_really dflags ctx vars ty qs
-  | incomplete && shadow = 
-      dsShadowWarn ctx eqns_shadow             `thenDs`   \ () ->
-      dsIncompleteWarn ctx pats                        `thenDs`   \ () ->
-      match vars ty qs
-  | incomplete            = 
-      dsIncompleteWarn ctx pats                        `thenDs`   \ () ->
-      match vars ty qs
-  | shadow                = 
-      dsShadowWarn ctx eqns_shadow             `thenDs`   \ () ->
-      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)
+  = do { dflags <- getDOptsDs
+       ; matchCheck_really dflags ctx vars ty qs }
+
+matchCheck_really :: DynFlags
+                  -> DsMatchContext
+                  -> [Id]
+                  -> Type
+                  -> [EquationInfo]
+                  -> DsM MatchResult
+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.
@@ -86,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}
 
@@ -97,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)
 
 
@@ -109,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)
+            FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> 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}
 
@@ -222,7 +242,7 @@ Make all constructor patterns in column~1 into @ConPats@, notably
 Handle any irrefutable (or ``twiddle'') @LazyPats@.
 \end{itemize}
 \item
-Now {\em unmix} the equations into {\em blocks} [w/ local function
+Now {\em unmix} the equations into {\em blocks} [w\/ local function
 @unmix_eqns@], in which the equations in a block all have variable
 patterns in column~1, or they all have constructor patterns in ...
 (see ``the mixture rule'' in SLPJ).
@@ -248,14 +268,14 @@ Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
 corresponds roughly to @matchVarCon@.
 
 \begin{code}
-match :: [Id]            -- Variables rep'ing the exprs we're matching with
+match :: [Id]            -- Variables rep\'ing the exprs we\'re matching with
       -> Type             -- Type of the case expression
       -> [EquationInfo]          -- Info about patterns, etc. (type synonym below)
       -> DsM MatchResult  -- Desugared result!
 
 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
@@ -265,11 +285,15 @@ 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
-       ; match_results <- mapM match_group (groupEquations tidy_eqns)
+        ; let grouped = groupEquations tidy_eqns
+
+         -- print the view patterns that are commoned up to help debug
+        ; ifDOptM 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,40 +301,87 @@ 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
-         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
+            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)
+            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)
+matchVariables [] _ _ = panic "matchVariables"
 
 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 (decomposeFirstPat getBangPat) eqns
        ; return (mkEvalMatchResult var ty match_result) }
-  where
-    shift eqn@(EqnInfo { eqn_pats = BangPat pat : pats })
-       = eqn { eqn_pats = unLoc pat : pats }
+matchBangs [] _ _ = panic "matchBangs"
 
 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))
-       ; 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 }
+       ; var' <- newUniqueId var (hsPatType pat)
+       ; 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
+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 var (hsPatType pat)
+       ; match_result <- match (var':vars) ty $
+                          map (decomposeFirstPat getViewPat) eqns
+         -- compile the view expressions
+        ; 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}
+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}
 
 %************************************************************************
@@ -370,9 +441,12 @@ tidyEqnInfo :: Id -> EquationInfo
        --      NPlusKPat
        -- but no other
 
+tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) 
+  = panic "tidyEqnInfo"
+
 tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
-  = tidy1 v pat        `thenDs` \ (wrap, pat') ->
-    returnDs (wrap, eqn { 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
@@ -392,17 +466,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 (idWrapper, 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)) 
-
-tidy1 v (VarPatOut var binds)
-  = do { prs <- dsLHsBinds binds
-       ; return (wrapBind var v . mkDsLet (Rec prs),
-                 WildPat (idType var)) }
+  = return (wrapBind var v, WildPat (idType var)) 
 
        -- case v of { x@p -> mr[] }
        -- = case v of { p -> let x=v in mr[] }
@@ -424,10 +493,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 (mkCoreLets sel_binds, WildPat (idType v)) }
 
-tidy1 v (ListPat pats ty)
-  = returnDs (idWrapper, 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)
@@ -436,39 +505,44 @@ 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 (idWrapper, 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 (idWrapper, 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
 
-tidy1 v (DictPat dicts methods)
-  = case num_of_d_and_ms of
-       0 -> tidy1 v (TuplePat [] Boxed unitTy) 
-       1 -> tidy1 v (unLoc (head dict_and_method_pats))
-       _ -> tidy1 v (mkVanillaTuplePat dict_and_method_pats Boxed)
-  where
-    num_of_d_and_ms     = length dicts + length methods
-    dict_and_method_pats = map nlVarPat (dicts ++ methods)
-
 -- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 v (LitPat lit)
-  = returnDs (idWrapper, 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 (idWrapper, tidyNPat lit mb_neg eq lit_ty)
+tidy1 _ (NPat 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 _ (WildPat _)))     = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (CoPat _ _ _)))   = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (SigPatIn _ _)))  = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (SigPatOut _ _))) = return (idDsWrapper, p)
+tidy1 v (BangPat (L _ (AsPat (L _ var) pat)))
+  = do { (wrap, pat') <- tidy1 v (BangPat pat)
+        ; return (wrapBind var v . wrap, pat') }
+tidy1 v (BangPat (L _ p))                   = tidy1 v p
 
 -- Everything else goes through unchanged...
 
-tidy1 v non_interesting_pat
-  = returnDs (idWrapper, non_interesting_pat)
+tidy1 _ non_interesting_pat
+  = return (idDsWrapper, non_interesting_pat)
 \end{code}
 
 \noindent
@@ -610,7 +684,8 @@ JJQC 30-Nov-1997
 
 \begin{code}
 matchWrapper ctxt (MatchGroup matches match_ty)
-  = do { eqns_info   <- mapM mk_eqn_info matches
+  = ASSERT( notNull matches )
+    do { eqns_info   <- mapM mk_eqn_info matches
        ; new_vars    <- selectMatchVars arg_pats
        ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
        ; return (new_vars, result_expr) }
@@ -629,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
-               error_string = matchContextErrString ctxt
+  = 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_string
+       ; 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}
 
 %************************************************************************
@@ -663,35 +731,30 @@ matchSimply :: CoreExpr                   -- Scrutinee
            -> CoreExpr                 -- Return this if it matches
            -> CoreExpr                 -- Return this if it doesn't
            -> DsM CoreExpr
-
-matchSimply scrut hs_ctx pat result_expr fail_expr
-  = let
+-- 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
-      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 ->
-    let
-       match_fn dflags
-           | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
-          | otherwise                          = match
-          where
-            ds_ctx = DsMatchContext hs_ctx locn
-    in
-    match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs  = 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
-  = selectSimpleMatchVarL pat                          `thenDs` \ var ->
-    matchSinglePat (Var var) hs_ctx pat ty match_result        `thenDs` \ match_result' ->
-    returnDs (adjustMatchResult (bindNonRec var scrut) 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}
 
 
@@ -712,30 +775,47 @@ 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], 
 -- (a) all the (pg,eq) pairs in g1 have the same pg
 -- (b) none of the gi are empty
+-- The ordering of equations is unchanged
 groupEquations eqns
   = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
   where
     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
     (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
 
-subGroups :: [(PatGroup, EquationInfo)] -> [[EquationInfo]]
+subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
 -- Input is a particular group.  The result sub-groups the 
 -- equations by with particular constructor, literal etc they match.
--- The order may be swizzled, so the matching should be order-independent
-subGroups groups = map (map snd) (equivClasses cmp groups)
+-- Each sub-list in the result has the same PatGroup
+-- See Note [Take care with pattern order]
+subGroup group 
+    = map reverse $ Map.elems $ foldl accumulate Map.empty group
   where
-    (pg1, _) `cmp` (pg2, _) = pg1 `cmp_pg` pg2
-    (PgCon c1) `cmp_pg` (PgCon c2) = c1 `compare` c2
-    (PgLit l1) `cmp_pg` (PgLit l2) = l1 `compare` l2
-    (PgN   l1) `cmp_pg` (PgN   l2) = l1 `compare` l2
-       -- These are the only cases that are every sub-grouped
+    accumulate 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 :: Map a [EquationInfo]
+    -- Equations seen so far in reverse order of appearance
+\end{code}
+
+Note [Take care with pattern order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the subGroup function we must be very careful about pattern re-ordering,
+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
+Then in bringing together the patterns for True, we must not 
+swap the Nothing and y!
 
+
+\begin{code}
 sameGroup :: PatGroup -> PatGroup -> Bool
 -- Same group means that a single case expression 
 -- or test will suffice to match both, *and* the order
@@ -744,29 +824,127 @@ 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 (PgNpK l1) (PgNpK l2) = l1==l2       -- Order is significant
-                                               -- See Note [Order of n+k]
-sameGroup (PgCo        t1)  (PgCo t2)  = t1 `coreEqType` t2
+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 `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
        -- 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,_) = 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
 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}
 
-Note [Order of n+k]
-~~~~~~~~~~~~~~~~~~~
+Note [Grouping overloaded literal patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 WATCH OUT!  Consider
 
        f (n+1) = ...
@@ -774,9 +952,12 @@ WATCH OUT!  Consider
        f (n+1) = ...
 
 We can't group the first and third together, because the second may match 
-the same thing as the first.  Contrast
-       f 1 = ...
-       f 2 = ...
-       f 1 = ...
-where we can group the first and third.  Hence we don't regard (n+1) and
-(n+2) as part of the same group.
+the same thing as the first.  Same goes for *overloaded* literal patterns
+       f 1 True = ...
+       f 2 False = ...
+       f 1 False = ...
+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.
+