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( ...@@ -29,7 +29,7 @@ module TcRnTypes(
-- Insts -- Insts
Inst(..), EqInstCo, InstOrigin(..), InstLoc(..), Inst(..), EqInstCo, InstOrigin(..), InstLoc(..),
pprInstLoc, pprInstArising, instLocSpan, instLocOrigin, pprInstLoc, pprInstArising, instLocSpan, instLocOrigin, setInstLoc,
LIE, emptyLIE, unitLIE, plusLIE, consLIE, instLoc, instSpan, LIE, emptyLIE, unitLIE, plusLIE, consLIE, instLoc, instSpan,
plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
...@@ -868,6 +868,9 @@ data InstLoc = InstLoc InstOrigin SrcSpan ErrCtxt ...@@ -868,6 +868,9 @@ data InstLoc = InstLoc InstOrigin SrcSpan ErrCtxt
instLoc :: Inst -> InstLoc instLoc :: Inst -> InstLoc
instLoc inst = tci_loc inst instLoc inst = tci_loc inst
setInstLoc :: Inst -> InstLoc -> Inst
setInstLoc inst new_loc = inst { tci_loc = new_loc }
instSpan :: Inst -> SrcSpan instSpan :: Inst -> SrcSpan
instSpan wanted = instLocSpan (instLoc wanted) instSpan wanted = instLocSpan (instLoc wanted)
...@@ -912,7 +915,13 @@ data InstOrigin ...@@ -912,7 +915,13 @@ data InstOrigin
| ExprSigOrigin -- e :: ty | ExprSigOrigin -- e :: ty
| RecordUpdOrigin | RecordUpdOrigin
| ViewPatOrigin | ViewPatOrigin
| InstScOrigin -- Typechecking superclasses of an instance declaration | InstScOrigin -- Typechecking superclasses of an instance declaration
| NoScOrigin -- A very special hack; see TcSimplify,
-- Note [Recursive instances and superclases]
| DerivOrigin -- Typechecking deriving | DerivOrigin -- Typechecking deriving
| StandAloneDerivOrigin -- Typechecking stand-alone deriving | StandAloneDerivOrigin -- Typechecking stand-alone deriving
| DefaultOrigin -- Typechecking a default decl | DefaultOrigin -- Typechecking a default decl
...@@ -936,6 +945,7 @@ instance Outputable InstOrigin where ...@@ -936,6 +945,7 @@ instance Outputable InstOrigin where
ppr TupleOrigin = ptext (sLit "a tuple") ppr TupleOrigin = ptext (sLit "a tuple")
ppr NegateOrigin = ptext (sLit "a use of syntactic negation") ppr NegateOrigin = ptext (sLit "a use of syntactic negation")
ppr InstScOrigin = ptext (sLit "the superclasses of an instance declaration") 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 DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration")
ppr StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") ppr StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
ppr DefaultOrigin = ptext (sLit "a 'default' declaration") ppr DefaultOrigin = ptext (sLit "a 'default' declaration")
......
...@@ -1265,9 +1265,23 @@ the givens, as you can see from the derivation described above. ...@@ -1265,9 +1265,23 @@ the givens, as you can see from the derivation described above.
Conclusion: in the very special case of tcSimplifySuperClasses Conclusion: in the very special case of tcSimplifySuperClasses
we have one 'given' (namely the "this" dictionary) whose superclasses we have one 'given' (namely the "this" dictionary) whose superclasses
must not be added to 'givens' by addGiven. That is the *whole* reason must not be added to 'givens' by addGiven.
for the red_given_scs field in RedEnv, and the function argument to
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} \begin{code}
tcSimplifySuperClasses tcSimplifySuperClasses
...@@ -1279,20 +1293,23 @@ tcSimplifySuperClasses ...@@ -1279,20 +1293,23 @@ tcSimplifySuperClasses
-> TcM TcDictBinds -> TcM TcDictBinds
tcSimplifySuperClasses loc this givens sc_wanteds tcSimplifySuperClasses loc this givens sc_wanteds
= do { traceTc (text "tcSimplifySuperClasses") = 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 ; (irreds,binds1) <- checkLoop env sc_wanteds
; let (tidy_env, tidy_irreds) = tidyInsts irreds ; let (tidy_env, tidy_irreds) = tidyInsts irreds
; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds ; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds
; return binds1 } ; return binds1 }
where 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 try_me _ = ReduceMe -- Try hard, so we completely solve the superclass
-- constraints right here. See Note [SUPERCLASS-LOOP 1] -- constraints right here. See Note [SUPERCLASS-LOOP 1]
\end{code} \end{code}
...@@ -1761,8 +1778,6 @@ data RedEnv ...@@ -1761,8 +1778,6 @@ data RedEnv
-- Always dicts & equalities -- Always dicts & equalities
-- but see Note [Rigidity] -- but see Note [Rigidity]
, red_given_scs :: Inst -> WantSCs -- See Note [Recursive instances and superclases]
, red_stack :: (Int, [Inst]) -- Recursion stack (for err msg) , red_stack :: (Int, [Inst]) -- Recursion stack (for err msg)
-- See Note [RedStack] -- See Note [RedStack]
} }
...@@ -1785,7 +1800,6 @@ mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv ...@@ -1785,7 +1800,6 @@ mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv
mkRedEnv doc try_me givens mkRedEnv doc try_me givens
= RedEnv { red_doc = doc, red_try_me = try_me, = RedEnv { red_doc = doc, red_try_me = try_me,
red_givens = givens, red_givens = givens,
red_given_scs = const AddSCs,
red_stack = (0,[]), red_stack = (0,[]),
red_improve = True } red_improve = True }
...@@ -1794,7 +1808,6 @@ mkInferRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv ...@@ -1794,7 +1808,6 @@ mkInferRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv
mkInferRedEnv doc try_me mkInferRedEnv doc try_me
= RedEnv { red_doc = doc, red_try_me = try_me, = RedEnv { red_doc = doc, red_try_me = try_me,
red_givens = [], red_givens = [],
red_given_scs = const AddSCs,
red_stack = (0,[]), red_stack = (0,[]),
red_improve = True } red_improve = True }
...@@ -1803,7 +1816,6 @@ mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv ...@@ -1803,7 +1816,6 @@ mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv
mkNoImproveRedEnv doc try_me mkNoImproveRedEnv doc try_me
= RedEnv { red_doc = doc, red_try_me = try_me, = RedEnv { red_doc = doc, red_try_me = try_me,
red_givens = [], red_givens = [],
red_given_scs = const AddSCs,
red_stack = (0,[]), red_stack = (0,[]),
red_improve = True } red_improve = True }
...@@ -1887,8 +1899,7 @@ reduceContext env wanteds0 ...@@ -1887,8 +1899,7 @@ reduceContext env wanteds0
-- Build the Avail mapping from "given_dicts" -- Build the Avail mapping from "given_dicts"
; (init_state, _) <- getLIE $ do ; (init_state, _) <- getLIE $ do
{ init_state <- foldlM (addGiven (red_given_scs env)) { init_state <- foldlM addGiven emptyAvails givens'
emptyAvails givens'
; return init_state ; return init_state
} }
...@@ -2602,14 +2613,19 @@ addWanted want_scs avails wanted rhs_expr wanteds ...@@ -2602,14 +2613,19 @@ addWanted want_scs avails wanted rhs_expr wanteds
where where
avail = Rhs rhs_expr wanteds avail = Rhs rhs_expr wanteds
addGiven :: (Inst -> WantSCs) -> Avails -> Inst -> TcM Avails addGiven :: Avails -> Inst -> TcM Avails
addGiven want_scs avails given = addAvailAndSCs (want_scs given) avails given (Given given) addGiven avails given
-- Conditionally add superclasses for 'givens' = 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] -- See Note [Recursive instances and superclases]
--
-- No ASSERT( not (given `elemAvails` avails) ) because in an instance -- No ASSERT( not (given `elemAvails` avails) ) because in an
-- decl for Ord t we can add both Ord t and Eq t as 'givens', -- instance decl for Ord t we can add both Ord t and Eq t as
-- so the assert isn't true -- 'givens', so the assert isn't true
\end{code} \end{code}
\begin{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