Merge master into the ghc-new-co branch
[ghc.git] / compiler / deSugar / Match.lhs
index d72d6ad..1a044d3 100644 (file)
@@ -1,38 +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 )
-import Check            ( check, ExhaustivePat )
+import TcHsSyn
+import Check
 import CoreSyn
-import CoreUtils       ( bindNonRec, exprType )
+import Literal
+import CoreUtils
+import MkCore
 import DsMonad
-import DsBinds         ( dsLHsBinds )
-import DsGRHSs         ( dsGRHSs )
+import DsBinds
+import DsGRHSs
 import DsUtils
-import Id              ( idName, idType, Id )
-import DataCon         ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon )
-import MatchCon                ( matchConFamily )
-import MatchLit                ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
-import PrelInfo                ( pAT_ERROR_ID )
-import TcType          ( Type, tcTyConAppArgs )
-import Type            ( splitFunTysN, mkTyVarTys )
-import TysWiredIn      ( consDataCon, mkListTy, unitTy,
-                         tupleCon, parrFakeCon, mkPArrTy )
-import BasicTypes      ( Boxity(..) )
-import ListSetOps      ( runs )
-import SrcLoc          ( noLoc, unLoc, Located(..) )
-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 
@@ -50,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.
@@ -83,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}
 
@@ -91,56 +109,67 @@ The next two functions create the warning message.
 \begin{code}
 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
 dsShadowWarn ctx@(DsMatchContext kind loc) qs
-  = putSrcSpanDs loc (dsWarn warn)
+  = 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)
 
 
 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
 dsIncompleteWarn ctx@(DsMatchContext kind loc) pats 
-  = putSrcSpanDs loc (dsWarn warn)
+  = 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}
 
 
+%************************************************************************
+%*                                                                     *
+               The main matching function
+%*                                                                     *
+%************************************************************************
+
 The function @match@ is basically the same as in the Wadler chapter,
 except it is monadised, to carry around the name supply, info about
 annotations, etc.
@@ -191,13 +220,6 @@ Leaving out this third argument to @match@ (and slamming in lots of
 impossible to share the default expressions.  (Also, it stands no
 chance of working in our post-upheaval world of @Locals@.)
 \end{enumerate}
-So, the full type signature:
-\begin{code}
-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!
-\end{code}
 
 Note: @match@ is often called via @matchWrapper@ (end of this module),
 a function that does much of the house-keeping that goes with a call
@@ -220,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).
@@ -230,35 +252,10 @@ appropriate thing for each kind of column-1 pattern, usually ending up
 in a recursive call to @match@.
 \end{enumerate}
 
-%************************************************************************
-%*                                                                     *
-%*  match: empty rule                                                  *
-%*                                                                     *
-%************************************************************************
-\subsection[Match-empty-rule]{The ``empty rule''}
-
 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
 And gluing the ``success expressions'' together isn't quite so pretty.
 
-\begin{code}
-match [] ty eqns_info
-  = ASSERT( not (null eqns_info) )
-    returnDs (foldr1 combineMatchResults match_results)
-  where
-    match_results = [ ASSERT( null (eqn_pats eqn) ) 
-                     adjustMatchResult (eqn_wrap eqn) (eqn_rhs eqn)
-                   | eqn <- eqns_info ]
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-%*  match: non-empty rule                                              *
-%*                                                                     *
-%************************************************************************
-\subsection[Match-nonempty]{@match@ when non-empty: unmixing}
-
 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
@@ -271,40 +268,127 @@ Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
 corresponds roughly to @matchVarCon@.
 
 \begin{code}
-match vars@(v:_) ty eqns_info
-  = do { tidy_eqns <- mappM (tidyEqnInfo v) eqns_info
-       ; let eqns_blks = runs same_family tidy_eqns
-       ; match_results <- mappM match_block eqns_blks
-       ; ASSERT( not (null match_results) )
-         return (foldr1 combineMatchResults match_results) }
+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 )
+    return (foldr1 combineMatchResults match_results)
   where
-    same_family eqn1 eqn2 
-      = samePatFamily (firstPat eqn1) (firstPat eqn2)
-    match_block eqns
-      = case firstPat (head eqns) of
-         WildPat {}   -> matchVariables  vars ty eqns
-         ConPatOut {} -> matchConFamily  vars ty eqns
-         NPlusKPat {} -> matchNPlusKPats vars ty eqns
-         NPat {}      -> matchNPats      vars ty eqns
-         LitPat {}    -> matchLiterals   vars ty eqns
-
--- After tidying, there are only five kinds of patterns
-samePatFamily (WildPat {})   (WildPat {})   = True
-samePatFamily (ConPatOut {}) (ConPatOut {}) = True
-samePatFamily (NPlusKPat {}) (NPlusKPat {}) = True
-samePatFamily (NPat {})             (NPat {})      = True
-samePatFamily (LitPat {})    (LitPat {})    = True
-samePatFamily _                     _              = False
+    match_results = [ ASSERT( null (eqn_pats eqn) ) 
+                     eqn_rhs eqn
+                   | eqn <- eqns ]
+
+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
+
+               -- Group the equations and match each group in turn
+        ; 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
+    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
+    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)
+            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 (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 (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}
 
-
-\end{code}
+%************************************************************************
+%*                                                                     *
+               Tidying patterns
+%*                                                                     *
+%************************************************************************
 
 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
 which will be scrutinised.  This means:
@@ -342,7 +426,8 @@ Float,      Double, at least) are converted to unboxed form; e.g.,
 \end{description}
 
 \begin{code}
-tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
+tidyEqnInfo :: Id -> EquationInfo
+           -> DsM (DsWrapper, EquationInfo)
        -- DsM'd because of internal call to dsLHsBinds
        --      and mkSelectorBinds.
        -- "tidy1" does the interesting stuff, looking at
@@ -356,30 +441,18 @@ tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
        --      NPlusKPat
        -- but no other
 
-tidyEqnInfo v eqn@(EqnInfo { eqn_wrap = wrap, eqn_pats = pat : pats })
-  = tidy1 v wrap pat   `thenDs` \ (wrap', pat') ->
-    returnDs (eqn { eqn_wrap = wrap', eqn_pats = 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
-      -> DsWrapper             -- Previous wrapping bindings
       -> Pat Id                -- The pattern against which it is to be matched
-      -> DsM (DsWrapper,       -- Extra bindings around what to do afterwards
+      -> DsM (DsWrapper,       -- Extra bindings to do before the match
              Pat Id)           -- Equivalent pattern
 
--- The extra bindings etc are all wrapped around the RHS of the match
--- so they are only available when matching is complete.  But that's ok
--- becuase, for example, in the pattern x@(...), the x can only be
--- used in the RHS, not in the nested pattern, nor subsquent patterns
---
--- However this does have an awkward consequence.  The bindings in 
--- a VarPatOut get wrapped around the result in right to left order,
--- rather than left to right.  This only matters if one set of 
--- bindings can mention things used in another, and that can happen
--- if we allow equality dictionary bindings of form d1=d2.  
--- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart.
--- (Without this care in bindInstsOfLocalFuns, compiling 
--- Data.Generics.Schemes.hs fails in function everywhereBut.)
-
 -------------------------------------------------------
 --     (pat', mr') = tidy1 v pat mr
 -- tidies the *outer level only* of pat, giving pat'
@@ -391,27 +464,20 @@ tidy1 :: Id                       -- The Id being scrutinised
 --     NPat
 --     NPlusKPat
 
-tidy1 v wrap (ParPat pat)      = tidy1 v wrap (unLoc pat) 
-tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat) 
-tidy1 v wrap (WildPat ty)      = returnDs (wrap, WildPat ty)
+tidy1 v (ParPat pat)      = tidy1 v (unLoc pat) 
+tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) 
+tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)
 
        -- case v of { x -> mr[] }
        -- = case v of { _ -> let x=v in mr[] }
-tidy1 v wrap (VarPat var)
-  = returnDs (wrap . wrapBind var v, WildPat (idType var)) 
-
-tidy1 v wrap (VarPatOut var binds)
-  = do { prs <- dsLHsBinds binds
-       ; return (wrap . wrapBind var v . mkDsLet (Rec prs),
-                 WildPat (idType var)) }
+tidy1 v (VarPat var)
+  = return (wrapBind var v, WildPat (idType var)) 
 
        -- case v of { x@p -> mr[] }
        -- = case v of { p -> let x=v in mr[] }
-tidy1 v wrap (AsPat (L _ var) pat)
-  = tidy1 v (wrap . wrapBind var v) (unLoc pat)
-
-tidy1 v wrap (BangPat pat)
-  = tidy1 v (wrap . seqVar v) (unLoc pat)
+tidy1 v (AsPat (L _ var) pat)
+  = do { (wrap, pat') <- tidy1 v (unLoc pat)
+       ; return (wrapBind var v . wrap, pat') }
 
 {- now, here we handle lazy patterns:
     tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
@@ -424,22 +490,13 @@ tidy1 v wrap (BangPat pat)
     The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
 -}
 
-tidy1 v wrap (LazyPat pat)
-  = do { v' <- newSysLocalDs (idType v)
-       ; sel_prs <- mkSelectorBinds pat (Var v)
+tidy1 v (LazyPat pat)
+  = do { sel_prs <- mkSelectorBinds pat (Var v)
        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
-       ; returnDs (wrap . wrapBind v' v . mkDsLets sel_binds,
-                   WildPat (idType v)) }
-
--- re-express <con-something> as (ConPat ...) [directly]
+       ; return (mkCoreLets sel_binds, WildPat (idType v)) }
 
-tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty)
-  = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty)
-  where
-    tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps)
-
-tidy1 v wrap (ListPat pats ty)
-  = returnDs (wrap, 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)
@@ -448,67 +505,44 @@ tidy1 v wrap (ListPat pats ty)
 
 -- Introduce fake parallel array constructors to be able to handle parallel
 -- arrays with the existing machinery for constructor pattern
-tidy1 v wrap (PArrPat pats ty)
-  = returnDs (wrap, unLoc parrConPat)
+tidy1 _ (PArrPat pats ty)
+  = return (idDsWrapper, unLoc parrConPat)
   where
     arity      = length pats
     parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
 
-tidy1 v wrap (TuplePat pats boxity ty)
-  = returnDs (wrap, 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 wrap (DictPat dicts methods)
-  = case num_of_d_and_ms of
-       0 -> tidy1 v wrap (TuplePat [] Boxed unitTy) 
-       1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
-       _ -> tidy1 v wrap (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 wrap pat@(LitPat lit)
-  = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat)))
+tidy1 (LitPat lit)
+  = return (idDsWrapper, tidyLitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 v wrap pat@(NPat lit mb_neg _ lit_ty)
-  = returnDs (wrap, unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat)))
-
--- and everything else goes through unchanged...
-
-tidy1 v wrap non_interesting_pat
-  = returnDs (wrap, non_interesting_pat)
-
-
-tidy_con data_con ex_tvs pat_ty (PrefixCon ps)   = ps
-tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2]
-tidy_con data_con ex_tvs pat_ty (RecCon rpats)
-  | null rpats
-  =    -- Special case for C {}, which can be used for 
-       -- a constructor that isn't declared to have
-       -- fields at all
-    map (noLoc . WildPat) con_arg_tys'
-
-  | otherwise
-  = map mk_pat tagged_arg_tys
-  where
-       -- Boring stuff to find the arg-tys of the constructor
-       
-    inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty       -- Newtypes must be opaque
-            | otherwise                 = mkTyVarTys ex_tvs
-
-    con_arg_tys'     = dataConInstOrigArgTys data_con inst_tys
-    tagged_arg_tys   = con_arg_tys' `zip` dataConFieldLabels data_con
-
-       -- mk_pat picks a WildPat of the appropriate type for absent fields,
-       -- and the specified pattern for present fields
-    mk_pat (arg_ty, lbl) = 
-       case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of
-         (pat:pats) -> ASSERT( null pats ) pat
-         []         -> noLoc (WildPat arg_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 _ non_interesting_pat
+  = return (idDsWrapper, non_interesting_pat)
 \end{code}
 
 \noindent
@@ -650,42 +684,34 @@ JJQC 30-Nov-1997
 
 \begin{code}
 matchWrapper ctxt (MatchGroup matches match_ty)
-  = do { eqns_info   <- mapM mk_eqn_info matches
-       ; new_vars    <- selectMatchVars arg_pats pat_tys
+  = 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) }
   where
-    arg_pats          = map unLoc (hsLMatchPats (head matches))
-    n_pats           = length arg_pats
-    (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty
+    arg_pats    = map unLoc (hsLMatchPats (head matches))
+    n_pats     = length arg_pats
+    (_, rhs_ty) = splitFunTysN n_pats match_ty
 
     mk_eqn_info (L _ (Match pats _ grhss))
       = do { let upats = map unLoc pats
           ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
-          ; return (EqnInfo { eqn_wrap = idWrapper,
-                              eqn_pats = upats, 
-                              eqn_rhs  = match_result}) }
+          ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
 
 
 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}
 
 %************************************************************************
@@ -705,36 +731,233 @@ 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_wrap = idWrapper,
-                                       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}
+
+
+%************************************************************************
+%*                                                                     *
+               Pattern classification
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+data PatGroup
+  = PgAny              -- Immediate match: variables, wildcards, 
+                       --                  lazy patterns
+  | PgCon DataCon      -- Constructor patterns (incl list, tuple)
+  | PgLit Literal      -- Literal patterns
+  | PgN   Literal      -- Overloaded literals
+  | PgNpK Literal      -- n+k patterns
+  | 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
+
+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.
+-- 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
+    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
+-- of testing within the group is insignificant.
+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)   = 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 (NPlusKPat _ olit _ _)              = PgNpK (hsOverLitKey olit False)
+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 [Grouping overloaded literal patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+WATCH OUT!  Consider
+
+       f (n+1) = ...
+       f (n+2) = ...
+       f (n+1) = ...
+
+We can't group the first and third together, because the second may match 
+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.
+