Commit c04a5fe3 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent 6a104dcf
......@@ -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")
......
......@@ -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}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment