-
-\begin{code}
------------------------------------------------------------
-checkLoop :: RedEnv
- -> [Inst] -- Wanted
- -> TcM ([Inst], TcDictBinds)
--- Precondition: givens are completely rigid
--- Postcondition: returned Insts are zonked
-
-checkLoop env wanteds
- = go env wanteds
- where go env wanteds
- = do { -- We do need to zonk the givens; cf Note [Zonking RedEnv]
- ; env' <- zonkRedEnv env
- ; wanteds' <- zonkInsts wanteds
-
- ; (improved, binds, irreds) <- reduceContext env' wanteds'
-
- ; if null irreds || not improved then
- return (irreds, binds)
- else do
-
- -- If improvement did some unification, we go round again.
- -- We start again with irreds, not wanteds
- -- Using an instance decl might have introduced a fresh type
- -- variable which might have been unified, so we'd get an
- -- infinite loop if we started again with wanteds!
- -- See Note [LOOP]
- { (irreds1, binds1) <- go env' irreds
- ; return (irreds1, binds `unionBags` binds1) } }
-\end{code}
-
-Note [Zonking RedEnv]
-~~~~~~~~~~~~~~~~~~~~~
-It might appear as if the givens in RedEnv are always rigid, but that is not
-necessarily the case for programs involving higher-rank types that have class
-contexts constraining the higher-rank variables. An example from tc237 in the
-testsuite is
-
- class Modular s a | s -> a
-
- wim :: forall a w. Integral a
- => a -> (forall s. Modular s a => M s w) -> w
- wim i k = error "urk"
-
- test5 :: (Modular s a, Integral a) => M s a
- test5 = error "urk"
-
- test4 = wim 4 test4'
-
-Notice how the variable 'a' of (Modular s a) in the rank-2 type of wim is
-quantified further outside. When type checking test4, we have to check
-whether the signature of test5 is an instance of
-
- (forall s. Modular s a => M s w)
-
-Consequently, we will get (Modular s t_a), where t_a is a TauTv into the
-givens.
-
-Given the FD of Modular in this example, class improvement will instantiate
-t_a to 'a', where 'a' is the skolem from test5's signatures (due to the
-Modular s a predicate in that signature). If we don't zonk (Modular s t_a) in
-the givens, we will get into a loop as improveOne uses the unification engine
-Unify.tcUnifyTys, which doesn't know about mutable type variables.
-
-
-Note [LOOP]
-~~~~~~~~~~~
- class If b t e r | b t e -> r
- instance If T t e t
- instance If F t e e
- class Lte a b c | a b -> c where lte :: a -> b -> c
- instance Lte Z b T
- instance (Lte a b l,If l b a c) => Max a b c
-
-Wanted: Max Z (S x) y
-
-Then we'll reduce using the Max instance to:
- (Lte Z (S x) l, If l (S x) Z y)
-and improve by binding l->T, after which we can do some reduction
-on both the Lte and If constraints. What we *can't* do is start again
-with (Max Z (S x) y)!
-
-
-
-%************************************************************************
-%* *
- tcSimplifySuperClasses
-%* *
-%************************************************************************
-
-Note [SUPERCLASS-LOOP 1]
-~~~~~~~~~~~~~~~~~~~~~~~~
-We have to be very, very careful when generating superclasses, lest we
-accidentally build a loop. Here's an example:
-
- class S a
-
- class S a => C a where { opc :: a -> a }
- class S b => D b where { opd :: b -> b }
-
- instance C Int where
- opc = opd
-
- instance D Int where
- opd = opc
-
-From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
-Simplifying, we may well get:
- $dfCInt = :C ds1 (opd dd)
- dd = $dfDInt
- ds1 = $p1 dd
-Notice that we spot that we can extract ds1 from dd.
-
-Alas! Alack! We can do the same for (instance D Int):
-
- $dfDInt = :D ds2 (opc dc)
- dc = $dfCInt
- ds2 = $p1 dc
-
-And now we've defined the superclass in terms of itself.
-Two more nasty cases are in
- tcrun021
- tcrun033
-
-Solution:
- - Satisfy the superclass context *all by itself*
- (tcSimplifySuperClasses)
- - And do so completely; i.e. no left-over constraints
- to mix with the constraints arising from method declarations
-
-
-Note [Recursive instances and superclases]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this code, which arises in the context of "Scrap Your
-Boilerplate with Class".
-
- class Sat a
- class Data ctx a
- instance Sat (ctx Char) => Data ctx Char
- instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]
-
- class Data Maybe a => Foo a
-
- instance Foo t => Sat (Maybe t)
-
- instance Data Maybe a => Foo a
- instance Foo a => Foo [a]
- instance Foo [Char]
-
-In the instance for Foo [a], when generating evidence for the superclasses
-(ie in tcSimplifySuperClasses) we need a superclass (Data Maybe [a]).
-Using the instance for Data, we therefore need
- (Sat (Maybe [a], Data Maybe a)
-But we are given (Foo a), and hence its superclass (Data Maybe a).
-So that leaves (Sat (Maybe [a])). Using the instance for Sat means
-we need (Foo [a]). And that is the very dictionary we are bulding
-an instance for! So we must put that in the "givens". So in this
-case we have
- Given: Foo a, Foo [a]
- Watend: Data Maybe [a]
-
-BUT we must *not not not* put the *superclasses* of (Foo [a]) in
-the givens, which is what 'addGiven' would normally do. Why? Because
-(Data Maybe [a]) is the superclass, so we'd "satisfy" the wanted
-by selecting a superclass from Foo [a], which simply makes a loop.
-
-On the other hand we *must* put the superclasses of (Foo a) in
-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.
-
-\begin{code}
-tcSimplifySuperClasses
- :: InstLoc
- -> Inst -- The dict whose superclasses
- -- are being figured out
- -> [Inst] -- Given
- -> [Inst] -- Wanted
- -> TcM TcDictBinds
-tcSimplifySuperClasses loc this givens sc_wanteds
- = do { traceTc (text "tcSimplifySuperClasses")
- ; (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}
-
-
-%************************************************************************
-%* *
-\subsection{tcSimplifyRestricted}
-%* *
-%************************************************************************
-
-tcSimplifyRestricted infers which type variables to quantify for a
-group of restricted bindings. This isn't trivial.
-
-Eg1: id = \x -> x
- We want to quantify over a to get id :: forall a. a->a
-
-Eg2: eq = (==)
- We do not want to quantify over a, because there's an Eq a
- constraint, so we get eq :: a->a->Bool (notice no forall)
-
-So, assume:
- RHS has type 'tau', whose free tyvars are tau_tvs
- RHS has constraints 'wanteds'
-
-Plan A (simple)
- Quantify over (tau_tvs \ ftvs(wanteds))
- This is bad. The constraints may contain (Monad (ST s))
- where we have instance Monad (ST s) where...
- so there's no need to be monomorphic in s!
-
- Also the constraint might be a method constraint,
- whose type mentions a perfectly innocent tyvar:
- op :: Num a => a -> b -> a
- Here, b is unconstrained. A good example would be
- foo = op (3::Int)
- We want to infer the polymorphic type
- foo :: forall b. b -> b
-
-
-Plan B (cunning, used for a long time up to and including GHC 6.2)
- Step 1: Simplify the constraints as much as possible (to deal
- with Plan A's problem). Then set
- qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
-
- Step 2: Now simplify again, treating the constraint as 'free' if
- it does not mention qtvs, and trying to reduce it otherwise.
- The reasons for this is to maximise sharing.
-
- This fails for a very subtle reason. Suppose that in the Step 2
- a constraint (Foo (Succ Zero) (Succ Zero) b) gets thrown upstairs as 'free'.
- In the Step 1 this constraint might have been simplified, perhaps to
- (Foo Zero Zero b), AND THEN THAT MIGHT BE IMPROVED, to bind 'b' to 'T'.
- This won't happen in Step 2... but that in turn might prevent some other
- constraint (Baz [a] b) being simplified (e.g. via instance Baz [a] T where {..})
- and that in turn breaks the invariant that no constraints are quantified over.
-
- Test typecheck/should_compile/tc177 (which failed in GHC 6.2) demonstrates
- the problem.
-
-
-Plan C (brutal)
- Step 1: Simplify the constraints as much as possible (to deal
- with Plan A's problem). Then set
- qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
- Return the bindings from Step 1.
-
-
-A note about Plan C (arising from "bug" reported by George Russel March 2004)
-Consider this:
-
- instance (HasBinary ty IO) => HasCodedValue ty
-
- foo :: HasCodedValue a => String -> IO a
-
- doDecodeIO :: HasCodedValue a => () -> () -> IO a
- doDecodeIO codedValue view
- = let { act = foo "foo" } in act
-
-You might think this should work becuase the call to foo gives rise to a constraint
-(HasCodedValue t), which can be satisfied by the type sig for doDecodeIO. But the
-restricted binding act = ... calls tcSimplifyRestricted, and PlanC simplifies the
-constraint using the (rather bogus) instance declaration, and now we are stuffed.
-
-I claim this is not really a bug -- but it bit Sergey as well as George. So here's
-plan D
-
-
-Plan D (a variant of plan B)
- Step 1: Simplify the constraints as much as possible (to deal
- with Plan A's problem), BUT DO NO IMPROVEMENT. Then set
- qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
-
- Step 2: Now simplify again, treating the constraint as 'free' if
- it does not mention qtvs, and trying to reduce it otherwise.
-
- The point here is that it's generally OK to have too few qtvs; that is,
- to make the thing more monomorphic than it could be. We don't want to
- do that in the common cases, but in wierd cases it's ok: the programmer
- can always add a signature.
-
- Too few qtvs => too many wanteds, which is what happens if you do less
- improvement.
-
-
-\begin{code}
-tcSimplifyRestricted -- Used for restricted binding groups
- -- i.e. ones subject to the monomorphism restriction
- :: SDoc
- -> TopLevelFlag
- -> [Name] -- Things bound in this group
- -> TcTyVarSet -- Free in the type of the RHSs
- -> [Inst] -- Free in the RHSs
- -> TcM ([TyVar], -- Tyvars to quantify (zonked and quantified)
- TcDictBinds) -- Bindings
- -- tcSimpifyRestricted returns no constraints to
- -- quantify over; by definition there are none.
- -- They are all thrown back in the LIE
-
-tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
- -- Zonk everything in sight
- = do { traceTc (text "tcSimplifyRestricted")
- ; wanteds_z <- zonkInsts wanteds
-
- -- 'ReduceMe': Reduce as far as we can. Don't stop at
- -- dicts; the idea is to get rid of as many type
- -- variables as possible, and we don't want to stop
- -- at (say) Monad (ST s), because that reduces
- -- immediately, with no constraint on s.
- --
- -- BUT do no improvement! See Plan D above
- -- HOWEVER, some unification may take place, if we instantiate
- -- a method Inst with an equality constraint
- ; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe)
- ; (_imp, _binds, constrained_dicts) <- reduceContext env wanteds_z
-
- -- Next, figure out the tyvars we will quantify over
- ; tau_tvs' <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
- ; gbl_tvs' <- tcGetGlobalTyVars
- ; constrained_dicts' <- zonkInsts constrained_dicts
-
- ; let qtvs1 = tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs'
- -- As in tcSimplifyInfer
-
- -- Do not quantify over constrained type variables:
- -- this is the monomorphism restriction
- constrained_tvs' = tyVarsOfInsts constrained_dicts'
- qtvs = qtvs1 `minusVarSet` constrained_tvs'
- pp_bndrs = pprWithCommas (quotes . ppr) bndrs
-
- -- Warn in the mono
- ; warn_mono <- doptM Opt_WarnMonomorphism
- ; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1))
- (vcat[ ptext (sLit "the Monomorphism Restriction applies to the binding")
- <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs,
- ptext (sLit "Consider giving a type signature for") <+> pp_bndrs])
-
- ; traceTc (text "tcSimplifyRestricted" <+> vcat [
- pprInsts wanteds, pprInsts constrained_dicts',
- ppr _binds,
- ppr constrained_tvs', ppr tau_tvs', ppr qtvs ])
-
- -- Zonk wanteds again! The first call to reduceContext may have
- -- instantiated some variables.
- -- FIXME: If red_improve would work, we could propagate that into
- -- the equality solver, too, to prevent instantating any
- -- variables.
- ; wanteds_zz <- zonkInsts wanteds_z
-
- -- The first step may have squashed more methods than
- -- necessary, so try again, this time more gently, knowing the exact
- -- set of type variables to quantify over.
- --
- -- We quantify only over constraints that are captured by qtvs;
- -- these will just be a subset of non-dicts. This in contrast
- -- to normal inference (using isFreeWhenInferring) in which we quantify over
- -- all *non-inheritable* constraints too. This implements choice
- -- (B) under "implicit parameter and monomorphism" above.
- --
- -- Remember that we may need to do *some* simplification, to
- -- (for example) squash {Monad (ST s)} into {}. It's not enough
- -- just to float all constraints
- --
- -- At top level, we *do* squash methods becuase we want to
- -- expose implicit parameters to the test that follows
- ; let is_nested_group = isNotTopLevel top_lvl
- try_me inst | isFreeWrtTyVars qtvs inst,
- (is_nested_group || isDict inst) = Stop
- | otherwise = ReduceMe
- env = mkNoImproveRedEnv doc try_me
- ; (_imp, binds, irreds) <- reduceContext env wanteds_zz
-
- -- See "Notes on implicit parameters, Question 4: top level"
- ; ASSERT( all (isFreeWrtTyVars qtvs) irreds ) -- None should be captured
- if is_nested_group then
- extendLIEs irreds
- else do { let (bad_ips, non_ips) = partition isIPDict irreds
- ; addTopIPErrs bndrs bad_ips
- ; extendLIEs non_ips }
-
- ; qtvs' <- zonkQuantifiedTyVars (varSetElems qtvs)
- ; return (qtvs', binds) }
-\end{code}
-
-
-%************************************************************************
-%* *
- tcSimplifyRuleLhs
-%* *
-%************************************************************************
-
-On the LHS of transformation rules we only simplify methods and constants,
-getting dictionaries. We want to keep all of them unsimplified, to serve
-as the available stuff for the RHS of the rule.