Fix Trac #2985: generating superclasses and recursive dictionaries

The Note [Recursive instances and superclases] explains the subtle
issues to do with generating the bindings for superclasses when
we compile an instance declaration, at least if we want to do the
clever "recursive superclass" idea from the SYB3 paper.

The old implementation of tcSimplifySuperClasses stumbled when
type equalities entered the picture (details in the Note); this
patch fixes the problem using a slightly hacky trick.  When we
re-engineer the constraint solver we'll want to keep an eye on
this.

Probably worth merging to the 6.10 branch.

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index ff8e3d6..28bfd8e 100644 (file)
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -29,7 +29,7 @@ module TcRnTypes(
 
        -- Insts
        Inst(..), EqInstCo, InstOrigin(..), InstLoc(..), 
-       pprInstLoc, pprInstArising, instLocSpan, instLocOrigin,
+       pprInstLoc, pprInstArising, instLocSpan, instLocOrigin, setInstLoc,
        LIE, emptyLIE, unitLIE, plusLIE, consLIE, instLoc, instSpan,
        plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
 
@@ -868,6 +868,9 @@ data InstLoc = InstLoc InstOrigin SrcSpan ErrCtxt
 instLoc :: Inst -> InstLoc
 instLoc inst = tci_loc inst
 
+setInstLoc :: Inst -> InstLoc -> Inst
+setInstLoc inst new_loc = inst { tci_loc = new_loc }
+
 instSpan :: Inst -> SrcSpan
 instSpan wanted = instLocSpan (instLoc wanted)
 
@@ -912,7 +915,13 @@ data InstOrigin
   | ExprSigOrigin      -- e :: ty
   | RecordUpdOrigin
   | ViewPatOrigin
+
   | InstScOrigin       -- Typechecking superclasses of an instance declaration
+
+  | NoScOrigin          -- A very special hack; see TcSimplify,
+                       --   Note [Recursive instances and superclases]
+                          
+
   | DerivOrigin                -- Typechecking deriving
   | StandAloneDerivOrigin -- Typechecking stand-alone deriving
   | DefaultOrigin      -- Typechecking a default decl
@@ -936,6 +945,7 @@ instance Outputable InstOrigin where
     ppr TupleOrigin          = ptext (sLit "a tuple")
     ppr NegateOrigin         = ptext (sLit "a use of syntactic negation")
     ppr InstScOrigin         = ptext (sLit "the superclasses of an instance declaration")
+    ppr NoScOrigin            = ptext (sLit "an instance declaration")
     ppr DerivOrigin          = ptext (sLit "the 'deriving' clause of a data type declaration")
     ppr StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
     ppr DefaultOrigin        = ptext (sLit "a 'default' declaration")

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}