module TcSimplify (
tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck,
tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
+
tcSimplifyThetas, tcSimplifyCheckThetas,
bindInstsOfLocalFuns
) where
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
- tyVarsOfInst, predsOfInsts,
+ tyVarsOfInst, predsOfInsts, predsOfInst,
isDict, isClassDict,
isStdClassTyVarDict, isMethodFor,
instToId, tyVarsOfInsts,
instBindingRequired, instCanBeGeneralised,
newDictsFromOld, instMentionsIPs,
- getDictClassTys, getIPs, isTyVarDict,
- instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
+ getDictClassTys, isTyVarDict,
+ instLoc, pprInst, zonkInst, tidyInsts,
Inst, LIE, pprInsts, pprInstsInFull,
- mkLIE,
- lieToList
+ mkLIE, lieToList
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
-import TcType ( zonkTcTyVarsAndFV )
+import TcType ( zonkTcTyVarsAndFV, tcInstTyVars )
import TcUnify ( unifyTauTy )
import Id ( idType )
import Name ( Name )
import NameSet ( mkNameSet )
-import Class ( Class, classBigSig )
+import Class ( classBigSig )
import FunDeps ( oclose, grow, improve )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
-import Type ( Type, ClassContext,
- mkTyVarTy, getTyVar,
- isTyVarTy, splitSigmaTy, tyVarsOfTypes
+import Type ( Type, ThetaType, PredType, mkClassPred,
+ mkTyVarTy, getTyVar, isTyVarClassPred,
+ splitSigmaTy, tyVarsOfPred,
+ getClassPredTys_maybe, isClassPred, isIPPred,
+ inheritablePred
)
-import Subst ( mkTopTyVarSubst, substClasses )
-import PprType ( pprClassPred )
+import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy )
import VarSet
import FiniteMap
import Outputable
import ListSetOps ( equivClasses )
-import Util ( zipEqual, mapAccumL )
+import Util ( zipEqual )
import List ( partition )
import CmdLineOpts
\end{code}
G the environment
T the type of the RHS
- C the constraints fromm that RHS
+ C the constraints from that RHS
The game is to figure out
Notice that we union before calling oclose. Here's an example:
- class J a b c | a,b -> c
+ class J a b c | a b -> c
fv(G) = {a}
Is this ambiguous?
- forall b,c. (J a b c) => b -> b
+ forall b c. (J a b c) => b -> b
Only if we union {a} from G with {b} from T before using oclose,
do we see that c is fixed.
try_me inst
| isFree qtvs inst = Free
| isClassDict inst = DontReduceUnlessConstant -- Dicts
- | otherwise = ReduceMe AddToIrreds -- Lits and Methods
+ | otherwise = ReduceMe -- Lits and Methods
in
-- Step 2
reduceContext doc try_me [] wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
-- Step 3
if no_improvement then
- returnTc (varSetElems qtvs, frees, binds, irreds)
+ returnTc (varSetElems qtvs, frees, binds, irreds)
else
- inferLoop doc tau_tvs wanteds
+ -- If improvement did some unification, we go round again. There
+ -- are two subtleties:
+ -- a) 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 example [LOOP]
+ --
+ -- b) It's also essential to re-process frees, because unification
+ -- might mean that a type variable that looked free isn't now.
+ --
+ -- Hence the (irreds ++ frees)
+
+ inferLoop doc tau_tvs (irreds ++ frees) `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
+ returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
\end{code}
+Example [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)!
+
\begin{code}
isFree qtvs inst
= not (tyVarsOfInst inst `intersectsVarSet` qtvs) -- Constrains no quantified vars
- && null (getIPs inst) -- And no implicit parameter involved
+ && all inheritablePred (predsOfInst inst) -- And no implicit parameter involved
-- (see "Notes on implicit parameters")
\end{code}
%************************************************************************
@tcSimplifyCheck@ is used when we know exactly the set of variables
-we are going to quantify over.
+we are going to quantify over. For example, a class or instance declaration.
\begin{code}
tcSimplifyCheck
-- When checking against a given signature we always reduce
-- until we find a match against something given, or can't reduce
try_me inst | isFree qtvs' inst = Free
- | otherwise = ReduceMe AddToIrreds
+ | otherwise = ReduceMe
in
-- Step 2
reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
-- Step 3
if no_improvement then
- returnTc (frees, binds, irreds)
+ returnTc (frees, binds, irreds)
else
- checkLoop doc qtvs givens wanteds
+ checkLoop doc qtvs givens' (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
+ returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
complainCheck doc givens irreds
= mapNF_Tc zonkInst given_dicts `thenNF_Tc` \ givens' ->
@tcSimplifyInferCheck@ is used when we know the consraints we are to simplify
against, but we don't know the type variables over which we are going to quantify.
+This happens when we have a type signature for a mutually recursive
+group.
\begin{code}
tcSimplifyInferCheck
-- When checking against a given signature we always reduce
-- until we find a match against something given, or can't reduce
try_me inst | isFree qtvs inst = Free
- | otherwise = ReduceMe AddToIrreds
+ | otherwise = ReduceMe
in
-- Step 2
reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
-- Step 3
if no_improvement then
- returnTc (varSetElems qtvs, frees, binds, irreds)
+ returnTc (varSetElems qtvs, frees, binds, irreds)
else
- inferCheckLoop doc tau_tvs givens wanteds
+ inferCheckLoop doc tau_tvs givens' (irreds ++ frees) `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
+ returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
\end{code}
-
%************************************************************************
%* *
\subsection{tcSimplifyToDicts}
But that means that we must simplify the Method for f to (f Int dNumInt)!
So tcSimplifyToDicts squeezes out all Methods.
+IMPORTANT NOTE: we *don't* want to do superclass commoning up. Consider
+
+ fromIntegral :: (Integral a, Num b) => a -> b
+ {-# RULES "foo" fromIntegral = id :: Int -> Int #-}
+
+Here, a=b=Int, and Num Int is a superclass of Integral Int. But we *dont*
+want to get
+
+ forall dIntegralInt.
+ fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
+
+because the scsel will mess up matching. Instead we want
+
+ forall dIntegralInt, dNumInt.
+ fromIntegral Int Int dIntegralInt dNumInt = id Int
+
+Hence "DontReduce NoSCs"
+
\begin{code}
tcSimplifyToDicts :: LIE -> TcM ([Inst], TcDictBinds)
tcSimplifyToDicts wanted_lie
wanteds = lieToList wanted_lie
-- Reduce methods and lits only; stop as soon as we get a dictionary
- try_me inst | isDict inst = DontReduce
- | otherwise = ReduceMe AddToIrreds
+ try_me inst | isDict inst = DontReduce NoSCs
+ | otherwise = ReduceMe
\end{code}
here_ip ip = isDict ip && ip `instMentionsIPs` ip_set
-- Simplify any methods that mention the implicit parameter
- try_me inst | inst `instMentionsIPs` ip_set = ReduceMe AddToIrreds
+ try_me inst | inst `instMentionsIPs` ip_set = ReduceMe
| otherwise = Free
\end{code}
-- so it's worth building a set, so that
-- lookup (in isMethodFor) is faster
- try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
+ try_me inst | isMethodFor overloaded_set inst = ReduceMe
| otherwise = Free
\end{code}
\begin{code}
data WhatToDo
- = ReduceMe -- Try to reduce this
- NoInstanceAction -- What to do if there's no such instance
+ = ReduceMe -- Try to reduce this
+ -- If there's no instance, behave exactly like
+ -- DontReduce: add the inst to
+ -- the irreductible ones, but don't
+ -- produce an error message of any kind.
+ -- It might be quite legitimate such as (Eq a)!
- | DontReduce -- Return as irreducible
+ | DontReduce WantSCs -- Return as irreducible
| DontReduceUnlessConstant -- Return as irreducible unless it can
-- be reduced to a constant in one step
| Free -- Return as free
-data NoInstanceAction
- = Stop -- Fail; no error message
- -- (Only used when tautology checking.)
-
- | AddToIrreds -- Just add the inst to the irreductible ones; don't
- -- produce an error message of any kind.
- -- It might be quite legitimate such as (Eq a)!
+data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses
+ -- of a predicate when adding it to the avails
\end{code}
TcExpr -- The RHS
[Inst] -- Insts free in the RHS; we need these too
-pprAvails avails = vcat (map pprAvail (eltsFM avails))
+pprAvails avails = vcat [ppr inst <+> equals <+> pprAvail avail
+ | (inst,avail) <- fmToList avails ]
instance Outputable Avail where
ppr = pprAvail
-- For implicit parameters, all occurrences share the same
-- Id, so there is no need for synonym bindings
new_binds | new_id == id = binds
- | otherwise = binds `AndMonoBinds` new_bind
- new_bind = VarMonoBind new_id (HsVar id)
+ | otherwise = addBind binds new_id (HsVar id)
new_id = instToId w
- Just (Rhs rhs ws') -> go avails' (binds `AndMonoBinds` new_bind) irreds (ws' ++ ws)
+ Just (Rhs rhs ws') -> go avails' (addBind binds id rhs) irreds (ws' ++ ws)
where
id = instToId w
avails' = addToFM avails w (BoundTo id)
- new_bind = VarMonoBind id rhs
+
+addBind binds id rhs = binds `AndMonoBinds` VarMonoBind id rhs
\end{code}
if no_improvement then
returnTc (frees, binds, irreds)
else
- simpleReduceLoop doc try_me wanteds
+ simpleReduceLoop doc try_me (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
+ returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
\end{code}
reduceContext doc try_me givens wanteds
=
-{- traceTc (text "reduceContext" <+> (vcat [
+ traceTc (text "reduceContext" <+> (vcat [
text "----------------------",
doc,
text "given" <+> ppr givens,
text "----------------------"
])) `thenNF_Tc_`
--}
-- Build the Avail mapping from "givens"
foldlNF_Tc addGiven (emptyFM, []) givens `thenNF_Tc` \ init_state ->
-- In particular, avails includes all superclasses of everything
tcImprove avails `thenTc` \ no_improvement ->
-{-
traceTc (text "reduceContext end" <+> (vcat [
text "----------------------",
doc,
text "no_improvement =" <+> ppr no_improvement,
text "----------------------"
])) `thenNF_Tc_`
--}
let
(binds, irreds) = bindsAndIrreds avails wanteds
in
if null eqns then
returnTc True
else
- mapTc_ (\ (t1,t2) -> unifyTauTy t1 t2) eqns `thenTc_`
+ traceTc (ptext SLIT("Improve:") <+> vcat (map ppr_eqn eqns)) `thenNF_Tc_`
+ mapTc_ unify eqns `thenTc_`
returnTc False
+ where
+ unify (qtvs, t1, t2) = tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
+ unifyTauTy (substTy tenv t1) (substTy tenv t2)
+ ppr_eqn (qtvs, t1, t2) = ptext SLIT("forall") <+> braces (pprWithCommas ppr (varSetElems qtvs)) <+>
+ ppr t1 <+> equals <+> ppr t2
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
| otherwise
= case try_me wanted of {
- DontReduce -> addIrred state wanted
+ DontReduce want_scs -> addIrred want_scs state wanted
; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
-- First, see if the inst can be reduced to a constant in one step
- try_simple addIrred
+ try_simple (addIrred AddSCs) -- Assume want superclasses
; Free -> -- It's free so just chuck it upstairs
-- First, see if the inst can be reduced to a constant in one step
try_simple addFree
- ; ReduceMe no_instance_action -> -- It should be reduced
+ ; ReduceMe -> -- It should be reduced
lookupInst wanted `thenNF_Tc` \ lookup_result ->
case lookup_result of
GenInst wanteds' rhs -> reduceList stack try_me wanteds' state `thenTc` \ state' ->
SimpleInst rhs -> addWanted state wanted rhs []
NoInstance -> -- No such instance!
- case no_instance_action of
- Stop -> failTc
- AddToIrreds -> addIrred state wanted
+ -- Add it and its superclasses
+ addIrred AddSCs state wanted
}
where
avail | instBindingRequired free = BoundTo (instToId free)
| otherwise = NoRhs
-addGiven :: RedState -> Inst -> NF_TcM RedState
-addGiven state given = add_avail state given (BoundTo (instToId given))
-
-addIrred :: RedState -> Inst -> NF_TcM RedState
-addIrred state irred = add_avail state irred Irred
-
addWanted :: RedState -> Inst -> TcExpr -> [Inst] -> NF_TcM RedState
-addWanted state wanted rhs_expr wanteds
+addWanted state@(avails, frees) wanted rhs_expr wanteds
+-- Do *not* add superclasses as well. Here's an example of why not
+-- class Eq a => Foo a b
+-- instance Eq a => Foo [a] a
+-- If we are reducing
+-- (Foo [t] t)
+-- we'll first deduce that it holds (via the instance decl). We
+-- must not then overwrite the Eq t constraint with a superclass selection!
+-- ToDo: this isn't entirely unsatisfactory, because
+-- we may also lose some entirely-legitimate sharing this way
+
= ASSERT( not (isAvailable state wanted) )
- add_avail state wanted avail
+ returnNF_Tc (addToFM avails wanted avail, frees)
where
avail | instBindingRequired wanted = Rhs rhs_expr wanteds
| otherwise = ASSERT( null wanteds ) NoRhs
-add_avail :: RedState -> Inst -> Avail -> NF_TcM RedState
-add_avail (avails, frees) wanted avail
- = addAvail avails wanted avail `thenNF_Tc` \ avails' ->
+addGiven :: RedState -> Inst -> NF_TcM RedState
+addGiven state given = addAvailAndSCs state given (BoundTo (instToId given))
+
+addIrred :: WantSCs -> RedState -> Inst -> NF_TcM RedState
+addIrred NoSCs (avails,frees) irred = returnNF_Tc (addToFM avails irred Irred, frees)
+addIrred AddSCs state irred = addAvailAndSCs state irred Irred
+
+addAvailAndSCs :: RedState -> Inst -> Avail -> NF_TcM RedState
+addAvailAndSCs (avails, frees) wanted avail
+ = add_avail_and_scs avails wanted avail `thenNF_Tc` \ avails' ->
returnNF_Tc (avails', frees)
---------------------
-addAvail :: Avails -> Inst -> Avail -> NF_TcM Avails
-addAvail avails wanted avail
- = addSuperClasses (addToFM avails wanted avail) wanted
+add_avail_and_scs :: Avails -> Inst -> Avail -> NF_TcM Avails
+add_avail_and_scs avails wanted avail
+ = add_scs (addToFM avails wanted avail) wanted
-addSuperClasses :: Avails -> Inst -> NF_TcM Avails
+add_scs :: Avails -> Inst -> NF_TcM Avails
-- Add all the superclasses of the Inst to Avails
-- Invariant: the Inst is already in Avails.
-addSuperClasses avails dict
+add_scs avails dict
| not (isClassDict dict)
= returnNF_Tc avails
| otherwise -- It is a dictionary
= newDictsFromOld dict sc_theta' `thenNF_Tc` \ sc_dicts ->
- foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_dicts sc_sels)
+ foldlNF_Tc add_sc avails (zipEqual "add_scs" sc_dicts sc_sels)
where
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _) = classBigSig clas
- sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
+ sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
= case lookupFM avails sc_dict of
Just (BoundTo _) -> returnNF_Tc avails -- See Note [SUPER] below
- other -> addAvail avails sc_dict avail
+ other -> add_avail_and_scs avails sc_dict avail
where
sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict]
avail = Rhs sc_sel_rhs [dict]
mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
-- And complain about the ones that don't
+ -- This group includes both non-existent instances
+ -- e.g. Num (IO a) and Eq (Int -> Int)
+ -- and ambiguous dictionaries
+ -- e.g. Num a
addTopAmbigErrs bad_guys `thenNF_Tc_`
returnTc (binds `andMonoBinds` andMonoBindList binds_ambig)
where
wanteds = lieToList wanted_lie
- try_me inst = ReduceMe AddToIrreds
+ try_me inst = ReduceMe
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
try_default (default_ty : default_tys)
= tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
-- default_tys instead
- tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
+ tcSimplifyCheckThetas [] theta `thenTc` \ _ ->
returnTc default_ty
where
- thetas = classes `zip` repeat [default_ty]
+ theta = [mkClassPred clas [default_ty] | clas <- classes]
in
-- See if any default works, and if so bind the type variable to it
-- If not, add an AmbigErr
- recoverTc (addAmbigErrs dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
+ recoverTc (addAmbigErrs dicts `thenNF_Tc_`
+ returnTc EmptyMonoBinds) $
try_default default_tys `thenTc` \ chosen_default_ty ->
returnTc EmptyMonoBinds
where
- try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
+ try_me inst = ReduceMe -- This reduce should not fail
tyvar = get_tv (head dicts) -- Should be non-empty
classes = map get_clas dicts
\end{code}
instance declarations.
\begin{code}
-tcSimplifyThetas :: ClassContext -- Wanted
- -> TcM ClassContext -- Needed
+tcSimplifyThetas :: ThetaType -- Wanted
+ -> TcM ThetaType -- Needed
tcSimplifyThetas wanteds
= doptsTc Opt_GlasgowExts `thenNF_Tc` \ glaExts ->
-- we expect an instance here
-- For Haskell 98, check that all the constraints are of the form C a,
-- where a is a type variable
- bad_guys | glaExts = [ct | ct@(clas,tys) <- irreds,
- isEmptyVarSet (tyVarsOfTypes tys)]
- | otherwise = [ct | ct@(clas,tys) <- irreds,
- not (all isTyVarTy tys)]
+ bad_guys | glaExts = [pred | pred <- irreds,
+ isEmptyVarSet (tyVarsOfPred pred)]
+ | otherwise = [pred | pred <- irreds,
+ not (isTyVarClassPred pred)]
in
if null bad_guys then
returnTc irreds
whether it worked or not.
\begin{code}
-tcSimplifyCheckThetas :: ClassContext -- Given
- -> ClassContext -- Wanted
+tcSimplifyCheckThetas :: ThetaType -- Given
+ -> ThetaType -- Wanted
-> TcM ()
tcSimplifyCheckThetas givens wanteds
\begin{code}
-type AvailsSimple = FiniteMap (Class,[Type]) Bool
+type AvailsSimple = FiniteMap PredType Bool
-- True => irreducible
-- False => given, or can be derived from a given or from an irreducible
-reduceSimple :: ClassContext -- Given
- -> ClassContext -- Wanted
- -> NF_TcM ClassContext -- Irreducible
+reduceSimple :: ThetaType -- Given
+ -> ThetaType -- Wanted
+ -> NF_TcM ThetaType -- Irreducible
reduceSimple givens wanteds
= reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
- returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
+ returnNF_Tc [pred | (pred,True) <- fmToList givens_fm']
where
givens_fm = foldl addNonIrred emptyFM givens
-reduce_simple :: (Int,ClassContext) -- Stack
+reduce_simple :: (Int,ThetaType) -- Stack
-> AvailsSimple
- -> ClassContext
+ -> ThetaType
-> NF_TcM AvailsSimple
reduce_simple (n,stack) avails wanteds
go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w `thenNF_Tc` \ avails' ->
go avails' ws
-reduce_simple_help stack givens wanted@(clas,tys)
+reduce_simple_help stack givens wanted
| wanted `elemFM` givens
= returnNF_Tc givens
- | otherwise
+ | Just (clas, tys) <- getClassPredTys_maybe wanted
= lookupSimpleInst clas tys `thenNF_Tc` \ maybe_theta ->
-
case maybe_theta of
Nothing -> returnNF_Tc (addSimpleIrred givens wanted)
Just theta -> reduce_simple stack (addNonIrred givens wanted) theta
-addSimpleIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
-addSimpleIrred givens ct@(clas,tys)
- = addSCs (addToFM givens ct True) ct
+ | otherwise
+ = returnNF_Tc (addSimpleIrred givens wanted)
+
+addSimpleIrred :: AvailsSimple -> PredType -> AvailsSimple
+addSimpleIrred givens pred
+ = addSCs (addToFM givens pred True) pred
-addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
-addNonIrred givens ct@(clas,tys)
- = addSCs (addToFM givens ct False) ct
+addNonIrred :: AvailsSimple -> PredType -> AvailsSimple
+addNonIrred givens pred
+ = addSCs (addToFM givens pred False) pred
-addSCs givens ct@(clas,tys)
- = foldl add givens sc_theta
+addSCs givens pred
+ | not (isClassPred pred) = givens
+ | otherwise = foldl add givens sc_theta
where
+ Just (clas,tys) = getClassPredTys_maybe pred
(tyvars, sc_theta_tmpl, _, _) = classBigSig clas
- sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
+ sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
- add givens ct@(clas, tys)
+ add givens ct
= case lookupFM givens ct of
Nothing -> -- Add it and its superclasses
addSCs (addToFM givens ct False) ct
= mapNF_Tc complain tidy_dicts
where
fixed_tvs = oclose (predsOfInsts tidy_dicts) emptyVarSet
- (tidy_env, tidy_dicts) = tidyInsts emptyTidyEnv dicts
- complain d | not (null (getIPs d)) = addTopIPErr tidy_env d
- | tyVarsOfInst d `subVarSet` fixed_tvs = addTopInstanceErr tidy_env d
+ (tidy_env, tidy_dicts) = tidyInsts dicts
+ complain d | any isIPPred (predsOfInst d) = addTopIPErr tidy_env d
+ | not (isTyVarDict d) ||
+ tyVarsOfInst d `subVarSet` fixed_tvs = addTopInstanceErr tidy_env d
| otherwise = addAmbigErr tidy_env d
addTopIPErr tidy_env tidy_dict
addAmbigErrs dicts
= mapNF_Tc (addAmbigErr tidy_env) tidy_dicts
where
- (tidy_env, tidy_dicts) = tidyInsts emptyTidyEnv dicts
+ (tidy_env, tidy_dicts) = tidyInsts dicts
addAmbigErr tidy_env tidy_dict
= addInstErrTcM (instLoc tidy_dict)
where
-- Tidy them first
- (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
+ (_, tidy_dicts) = tidyInsts dicts
-- Group the dictionaries by source location
groups = equivClasses cmp tidy_dicts
| otherwise
= ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
- (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
+ (tidy_env, tidy_dict:tidy_givens) = tidyInsts (dict:givens)
-- Checks for the ambiguous case when we have overlapping instances
ambig_overlap | isClassDict dict
addInstErrTcM (instLoc dict) (tidy_env, doc)
-- Used for the ...Thetas variants; all top level
-addNoInstErr (c,ts)
- = addErrTc (ptext SLIT("No instance for") <+> quotes (pprClassPred c ts))
+addNoInstErr pred
+ = addErrTc (ptext SLIT("No instance for") <+> quotes (ppr pred))
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
projects / ghc-hetmet.git / blobdiff