Properly keep track of whether normalising given or wanted dicts

- The information of whether given or wanted class dictionaries where
  normalised by rewriting wasn't always correctly propagated in TcTyFuns,
  which lead to malformed dictionary bindings.
- Also fixes a bug in TcPat.tcConPat where GADT equalities where emitted in
  the wrong position in case bindings (which led to CoreLint failures).

6 files changed, 42 insertions, 21 deletions

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 0c6e3c5720..7744e8bb54 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -338,19 +338,21 @@ data DataCon
 	dcRepTyCon  :: TyCon,		-- Result tycon, T
 
 	dcRepType   :: Type,	-- Type of the constructor
-				-- 	forall a x y. (a:=:(x,y), Ord x) => x -> y -> MkT a
+				-- 	forall a x y. (a:=:(x,y), x~y, Ord x) =>
+                                --        x -> y -> T a
 				-- (this is *not* of the constructor wrapper Id:
 				--  see Note [Data con representation] below)
 	-- Notice that the existential type parameters come *second*.  
 	-- Reason: in a case expression we may find:
-	--	case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... }
+	--	case (e :: T t) of
+        --        MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ...
 	-- It's convenient to apply the rep-type of MkT to 't', to get
-	--	forall b. Ord b => ...
+	--	forall x y. (t:=:(x,y), x~y, Ord x) => x -> y -> T t
 	-- and use that to check the pattern.  Mind you, this is really only
-	-- use in CoreLint.
+	-- used in CoreLint.
 
 
-	-- Finally, the curried worker function that corresponds to the constructor
+	-- The curried worker function that corresponds to the constructor:
 	-- It doesn't have an unfolding; the code generator saturates these Ids
 	-- and allocates a real constructor when it finds one.
 	--
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 395c72a446..adb67ad765 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -519,9 +519,10 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
 	  {    -- Check the pattern
 		 -- Scrutinee type must be a tycon applicn; checked by caller
 		 -- This code is remarkably compact considering what it does!
-		 -- NB: args must be in scope here so that the lintCoreArgs line works.
-	         -- NB: relies on existential type args coming *after* ordinary type args
-
+		 -- NB: args must be in scope here so that the lintCoreArgs
+		 --     line works. 
+	         -- NB: relies on existential type args coming *after*
+	         --     ordinary type args 
 	  ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
 	  ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) 
  	  }
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 66c57de074..68bf3f1f42 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -181,7 +181,7 @@ scrungleMatch var scrut body
     scrungle (Let binds body)  = Let binds (scrungle body)
     scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
 
-\end{code}	
+\end{code}
 
 %************************************************************************
 %*									*
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index c2f758de68..10946f3962 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -637,17 +637,21 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 	  then do { -- The common case; no class bindings etc 
                     -- (see Note [Arrows and patterns])
 		    (arg_pats', inner_tvs, res) <- tcConArgs data_con arg_tys' 
-							       arg_pats pstate thing_inside
+						    arg_pats pstate thing_inside
 		  ; let res_pat = ConPatOut { pat_con = L con_span data_con, 
-			            	      pat_tvs = [], pat_dicts = [], pat_binds = emptyLHsBinds,
-					      pat_args = arg_pats', pat_ty = pat_ty' }
+			            	      pat_tvs = [], pat_dicts = [], 
+                                              pat_binds = emptyLHsBinds,
+					      pat_args = arg_pats', 
+                                              pat_ty = pat_ty' }
 
 		    ; return (wrap_res_pat res_pat, inner_tvs, res) }
 
 	  else do   -- The general case, with existential, and local equality 
                     -- constraints
 	{ let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
-	      theta'   = substTheta tenv (full_theta ++ eq_preds)
+	      theta'   = substTheta tenv (eq_preds ++ full_theta)
+                           -- order is *important* as we generate the list of
+                           -- dictionary binders from theta'
 	      ctxt     = pat_ctxt pstate
 	; checkTc (case ctxt of { ProcPat -> False; other -> True })
 		  (existentialProcPat data_con)
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 33975947af..433266ec08 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1820,7 +1820,8 @@ reduceContext env wanteds
 
 	  -- 8. Substitute the wanted *equations* in the wanted *dictionaries*
 	; let irreds = dict_irreds ++ implic_irreds
-	; (norm_irreds, normalise_binds2) <- substEqInDictInsts eq_irreds irreds
+	; (norm_irreds, normalise_binds2) <- substEqInDictInsts True {-wanted-}
+                                                                eq_irreds irreds
 		
 	  -- 9. eliminate the artificial skolem constants introduced in 1.
 	; eliminate_skolems	
diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs
index d7da2f76e5..ca3c4a813d 100644
--- a/compiler/typecheck/TcTyFuns.lhs
+++ b/compiler/typecheck/TcTyFuns.lhs
@@ -388,14 +388,18 @@ normalise_dicts
 			-- Fals <=> they are given
 	-> TcM ([Inst],TcDictBinds)
 normalise_dicts given_eqs dicts is_wanted
-  = do	{ traceTc $ text "normalise???Dicts <-" <+> ppr dicts <+> 
+  = do	{ traceTc $ let name | is_wanted = "normaliseWantedDicts <-"
+                             | otherwise = "normaliseGivenDicts <-"
+                    in
+                    text name <+> ppr dicts <+> 
                     text "with" <+> ppr given_eqs
 	; (dicts0, binds0)  <- normaliseInsts is_wanted dicts
-	; (dicts1, binds1)  <- substEqInDictInsts given_eqs dicts0
+	; (dicts1, binds1)  <- substEqInDictInsts is_wanted given_eqs dicts0
 	; let binds01 = binds0 `unionBags` binds1
 	; if isEmptyBag binds1
 	  then return (dicts1, binds01)
-	  else do { (dicts2, binds2) <- normaliseGivenDicts given_eqs dicts1
+	  else do { (dicts2, binds2) <- 
+                      normalise_dicts given_eqs dicts1 is_wanted
 		  ; return (dicts2, binds01 `unionBags` binds2) } }
 \end{code}
 
@@ -1080,10 +1084,11 @@ form
 where F is a type family.
 
 \begin{code}
-substEqInDictInsts :: [Inst]    -- given equalities (used as rewrite rules)
+substEqInDictInsts :: Bool      -- whether the *dictionaries* are wanted/given
+                   -> [Inst]    -- given equalities (used as rewrite rules)
                    -> [Inst]    -- dictinaries to be normalised
                    -> TcM ([Inst], TcDictBinds)
-substEqInDictInsts eqInsts dictInsts 
+substEqInDictInsts isWanted eqInsts dictInsts 
   = do { traceTc (text "substEqInDictInst <-" <+> ppr dictInsts)
        ; dictInsts' <- 
            foldlM rewriteWithOneEquality (dictInsts, emptyBag) eqInsts
@@ -1097,7 +1102,7 @@ substEqInDictInsts eqInsts dictInsts
                                            tci_right = target})
       | isOpenSynTyConApp pattern || isTyVarTy pattern
       = do { (dictInsts', moreDictBinds) <- 
-               genericNormaliseInsts True {- wanted -} applyThisEq dictInsts
+               genericNormaliseInsts isWanted applyThisEq dictInsts
            ; return (dictInsts', dictBinds `unionBags` moreDictBinds)
            }
       where
@@ -1176,7 +1181,13 @@ genericNormaliseInsts isWanted fun insts
 			  rhs       = L (instLocSpan loc) cast_expr
 			  binds     = instToDictBind target_dict rhs
 		      -- return the new inst
-		    ; traceTc $ text "genericNormaliseInst ->" <+> ppr dict'
+		    ; traceTc $ let name | isWanted 
+                                         = "genericNormaliseInst (wanted) ->"
+                                         | otherwise
+                                         = "genericNormaliseInst (given) ->"
+                                in
+                                text name <+> ppr dict' <+>
+                                text "with" <+> ppr binds
                     ; return (dict', binds)
 		    }
 	   }
@@ -1184,6 +1195,8 @@ genericNormaliseInsts isWanted fun insts
 	-- TOMDO: What do we have to do about ImplicInst, Method, and LitInst??
     normaliseOneInst _isWanted _fun inst
       = do { inst' <- zonkInst inst
+           ; traceTc $ text "*** TcTyFuns.normaliseOneInst: Skipping" <+>
+                       ppr inst
 	   ; return (inst', emptyBag)
 	   }
 \end{code}