Fix Trac #2985: generating superclasses and recursive dictionaries

[ghc-hetmet.git] / compiler / typecheck / TcSimplify.lhs

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index ad7e5c2..071d4c0 100644 (file)
--- 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}