diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index ff8e3d630752d5b52bed1302b2a9010029acb082..28bfd8ecb72a8d7c3e35335f1263367334ca1868 100644 --- 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 ad7e5c2a30ae16618a0132be599f968fa8661ce7..071d4c0334c3a0a661ba863e4c14033d11492621 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}