X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=071d4c0334c3a0a661ba863e4c14033d11492621;hp=ad7e5c2a30ae16618a0132be599f968fa8661ce7;hb=c04a5fe3e2867d59ce9757069fdd20c06c326724;hpb=6a104dcf597f27887f0f1ac82dba7051ed2fe0c3

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index ad7e5c2..071d4c0 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1265,9 +1265,23 @@ the givens, as you can see from the derivation described above.
 
 Conclusion: in the very special case of tcSimplifySuperClasses
 we have one 'given' (namely the "this" dictionary) whose superclasses
-must not be added to 'givens' by addGiven.  That is the *whole* reason
-for the red_given_scs field in RedEnv, and the function argument to
-addGiven.
+must not be added to 'givens' by addGiven.  
+
+There is a complication though.  Suppose there are equalities
+      instance (Eq a, a~b) => Num (a,b)
+Then we normalise the 'givens' wrt the equalities, so the original
+given "this" dictionary is cast to one of a different type.  So it's a
+bit trickier than before to identify the "special" dictionary whose
+superclasses must not be added. See test
+   indexed-types/should_run/EqInInstance
+
+We need a persistent property of the dictionary to record this
+special-ness.  Current I'm using the InstLocOrigin (a bit of a hack,
+but cool), which is maintained by dictionary normalisation.
+Specifically, the InstLocOrigin is
+	     NoScOrigin
+then the no-superclass thing kicks in.  WATCH OUT if you fiddle
+with InstLocOrigin!
 
 \begin{code}
 tcSimplifySuperClasses
@@ -1279,20 +1293,23 @@ tcSimplifySuperClasses
 	-> TcM TcDictBinds
 tcSimplifySuperClasses loc this givens sc_wanteds
   = do	{ traceTc (text "tcSimplifySuperClasses")
+
+	      -- Note [Recursive instances and superclases]
+        ; no_sc_loc <- getInstLoc NoScOrigin
+	; let no_sc_this = setInstLoc this no_sc_loc
+
+	; let env =  RedEnv { red_doc = pprInstLoc loc, 
+	     		      red_try_me = try_me,
+	     	     	      red_givens = no_sc_this : givens, 
+	     	     	      red_stack = (0,[]),
+	     	     	      red_improve = False }  -- No unification vars
+
+
 	; (irreds,binds1) <- checkLoop env sc_wanteds
 	; let (tidy_env, tidy_irreds) = tidyInsts irreds
 	; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds
 	; return binds1 }
   where
-    env =  RedEnv { red_doc = pprInstLoc loc, 
-		    red_try_me = try_me,
-	     	    red_givens = this:givens, 
-	     	    red_given_scs = add_scs,
-	     	    red_stack = (0,[]),
-	     	    red_improve = False }  -- No unification vars
-    add_scs g | g==this   = NoSCs
-	      | otherwise = AddSCs
-
     try_me _ = ReduceMe  -- Try hard, so we completely solve the superclass 
     	       		 -- constraints right here. See Note [SUPERCLASS-LOOP 1]
 \end{code}
@@ -1761,8 +1778,6 @@ data RedEnv
 						-- Always dicts & equalities
 						-- but see Note [Rigidity]
  
- 	   , red_given_scs :: Inst -> WantSCs	-- See Note [Recursive instances and superclases]
- 
 	   , red_stack  :: (Int, [Inst])	-- Recursion stack (for err msg)
 						-- See Note [RedStack]
   }
@@ -1785,7 +1800,6 @@ mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv
 mkRedEnv doc try_me givens
   = RedEnv { red_doc = doc, red_try_me = try_me,
 	     red_givens = givens, 
-	     red_given_scs = const AddSCs,
 	     red_stack = (0,[]),
 	     red_improve = True }	
 
@@ -1794,7 +1808,6 @@ mkInferRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv
 mkInferRedEnv doc try_me
   = RedEnv { red_doc = doc, red_try_me = try_me,
 	     red_givens = [], 
-	     red_given_scs = const AddSCs,
 	     red_stack = (0,[]),
 	     red_improve = True }	
 
@@ -1803,7 +1816,6 @@ mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv
 mkNoImproveRedEnv doc try_me
   = RedEnv { red_doc = doc, red_try_me = try_me,
 	     red_givens = [], 
-	     red_given_scs = const AddSCs,
 	     red_stack = (0,[]),
 	     red_improve = True }	
 
@@ -1887,8 +1899,7 @@ reduceContext env wanteds0
 
           -- Build the Avail mapping from "given_dicts"
 	; (init_state, _) <- getLIE $ do 
-		{ init_state <- foldlM (addGiven (red_given_scs env)) 
-		  	     	       emptyAvails givens'
+		{ init_state <- foldlM addGiven emptyAvails givens'
 		; return init_state
                 }
 
@@ -2602,14 +2613,19 @@ addWanted want_scs avails wanted rhs_expr wanteds
   where
     avail = Rhs rhs_expr wanteds
 
-addGiven :: (Inst -> WantSCs) -> Avails -> Inst -> TcM Avails
-addGiven want_scs avails given = addAvailAndSCs (want_scs given) avails given (Given given)
-	-- Conditionally add superclasses for 'givens'
+addGiven :: Avails -> Inst -> TcM Avails
+addGiven avails given 
+  = addAvailAndSCs want_scs avails given (Given given)
+  where
+    want_scs = case instLocOrigin (instLoc given) of
+    	         NoScOrigin -> NoSCs
+		 _other	    -> AddSCs
+	-- Conditionally add superclasses for 'given'
 	-- See Note [Recursive instances and superclases]
-	--
-	-- No ASSERT( not (given `elemAvails` avails) ) because in an instance
-	-- decl for Ord t we can add both Ord t and Eq t as 'givens', 
-	-- so the assert isn't true
+
+  -- No ASSERT( not (given `elemAvails` avails) ) because in an
+  -- instance decl for Ord t we can add both Ord t and Eq t as
+  -- 'givens', so the assert isn't true
 \end{code}
 
 \begin{code}