tcSimplifyCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
- tcSimplifyThetas, tcSimplifyCheckThetas,
+ tcSimplifyDeriv, tcSimplifyDefault,
bindInstsOfLocalFuns
) where
)
import TcMonad
-import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
- tyVarsOfInst, predsOfInsts, predsOfInst,
+import Inst ( lookupInst, LookupInstResult(..),
+ tyVarsOfInst, predsOfInsts, predsOfInst, newDicts,
isDict, isClassDict, isLinearInst, linearInstType,
isStdClassTyVarDict, isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
- ipNamesOfInsts, ipNamesOfInst,
+ ipNamesOfInsts, ipNamesOfInst, dictPred,
instBindingRequired, instCanBeGeneralised,
newDictsFromOld, newMethodAtLoc,
getDictClassTys, isTyVarDict,
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupGlobalId )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
-import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars )
-import TcType ( TcTyVar, TcTyVarSet, ThetaType, PredType,
+import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
+import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
mkClassPred, isOverloadedTy, mkTyConApp,
- mkTyVarTy, tcGetTyVar, isTyVarClassPred,
- tyVarsOfPred, getClassPredTys_maybe, isClassPred, isIPPred,
- inheritablePred, predHasFDs )
+ mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
+ tyVarsOfPred, isIPPred, isInheritablePred, predHasFDs )
import Id ( idType, mkUserLocal )
+import Var ( TyVar )
import Name ( getOccName, getSrcLoc )
import NameSet ( NameSet, mkNameSet, elemNameSet )
import Class ( classBigSig )
import FunDeps ( oclose, grow, improve, pprEquationDoc )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass,
- splitIdName, fstIdName, sndIdName )
+ splitName, fstName, sndName )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy, pairTyCon )
isFreeWhenInferring :: TyVarSet -> Inst -> Bool
isFreeWhenInferring qtvs inst
= isFreeWrtTyVars qtvs inst -- Constrains no quantified vars
- && all inheritablePred (predsOfInst inst) -- And no implicit parameter involved
+ && all isInheritablePred (predsOfInst inst) -- And no implicit parameter involved
-- (see "Notes on implicit parameters")
isFreeWhenChecking :: TyVarSet -- Quantified tyvars
-- tcSimplifyCheck is used when checking expression type signatures,
-- class decls, instance decls etc.
--- Note that we psss isFree (not isFreeAndInheritable) to tcSimplCheck
+--
+-- NB: we psss isFree (not isFreeAndInheritable) to tcSimplCheck
-- It's important that we can float out non-inheritable predicates
-- Example: (?x :: Int) is ok!
+--
+-- NB: tcSimplifyCheck does not consult the
+-- global type variables in the environment; so you don't
+-- need to worry about setting them before calling tcSimplifyCheck
tcSimplifyCheck doc qtvs givens wanted_lie
= tcSimplCheck doc get_qtvs
givens wanted_lie `thenTc` \ (qtvs', frees, binds) ->
| Free -- Return as free
+reduceMe :: Inst -> WhatToDo
+reduceMe inst = ReduceMe
+
data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses
-- of a predicate when adding it to the avails
\end{code}
-- is turned into an LinRhss
[TcExpr] -- A supply of suitable RHSs
-pprAvails avails = vcat [ppr inst <+> equals <+> pprAvail avail
+pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)]
| (inst,avail) <- fmToList avails ]
instance Outputable Avail where
returnNF_Tc (andMonoBindList binds', concat rhss')
do_one rhs = tcGetUnique `thenNF_Tc` \ uniq ->
- tcLookupGlobalId fstIdName `thenNF_Tc` \ fst_id ->
- tcLookupGlobalId sndIdName `thenNF_Tc` \ snd_id ->
+ tcLookupGlobalId fstName `thenNF_Tc` \ fst_id ->
+ tcLookupGlobalId sndName `thenNF_Tc` \ snd_id ->
let
x = mkUserLocal occ uniq pair_ty loc
in
returnTc False
where
unify ((qtvs, t1, t2), doc)
- = tcAddErrCtxt doc $
- tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
+ = tcAddErrCtxt doc $
+ tcInstTyVars VanillaTv (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
unifyTauTy (substTy tenv t1) (substTy tenv t2)
\end{code}
addLinearAvailable :: Avails -> Avail -> Inst -> NF_TcM (Avails, [Inst])
addLinearAvailable avails avail wanted
| need_split avail
- = tcLookupGlobalId splitIdName `thenNF_Tc` \ split_id ->
+ = tcLookupGlobalId splitName `thenNF_Tc` \ split_id ->
newMethodAtLoc (instLoc wanted) split_id
[linearInstType wanted] `thenNF_Tc` \ (split_inst,_) ->
returnNF_Tc (addToFM avails wanted (Linear 2 split_inst avail), [split_inst])
%************************************************************************
-If a dictionary constrains a type variable which is
- * not mentioned in the environment
- * and not mentioned in the type of the expression
-then it is ambiguous. No further information will arise to instantiate
-the type variable; nor will it be generalised and turned into an extra
-parameter to a function.
-
-It is an error for this to occur, except that Haskell provided for
-certain rules to be applied in the special case of numeric types.
-Specifically, if
- * at least one of its classes is a numeric class, and
- * all of its classes are numeric or standard
-then the type variable can be defaulted to the first type in the
-default-type list which is an instance of all the offending classes.
-
-So here is the function which does the work. It takes the ambiguous
-dictionaries and either resolves them (producing bindings) or
-complains. It works by splitting the dictionary list by type
-variable, and using @disambigOne@ to do the real business.
-
@tcSimplifyTop@ is called once per module to simplify all the constant
and ambiguous Insts.
\begin{code}
tcSimplifyTop :: LIE -> TcM TcDictBinds
tcSimplifyTop wanted_lie
- = simpleReduceLoop (text "tcSimplTop") try_me wanteds `thenTc` \ (frees, binds, irreds) ->
+ = simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenTc` \ (frees, binds, irreds) ->
ASSERT( null frees )
let
returnTc (binds `andMonoBinds` andMonoBindList binds_ambig)
where
wanteds = lieToList wanted_lie
- try_me inst = ReduceMe
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
(clas, [ty]) -> clas
\end{code}
+If a dictionary constrains a type variable which is
+ * not mentioned in the environment
+ * and not mentioned in the type of the expression
+then it is ambiguous. No further information will arise to instantiate
+the type variable; nor will it be generalised and turned into an extra
+parameter to a function.
+
+It is an error for this to occur, except that Haskell provided for
+certain rules to be applied in the special case of numeric types.
+Specifically, if
+ * at least one of its classes is a numeric class, and
+ * all of its classes are numeric or standard
+then the type variable can be defaulted to the first type in the
+default-type list which is an instance of all the offending classes.
+
+So here is the function which does the work. It takes the ambiguous
+dictionaries and either resolves them (producing bindings) or
+complains. It works by splitting the dictionary list by type
+variable, and using @disambigOne@ to do the real business.
+
@disambigOne@ assumes that its arguments dictionaries constrain all
the same type variable.
try_default (default_ty : default_tys)
= tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
-- default_tys instead
- tcSimplifyCheckThetas [] theta `thenTc` \ _ ->
+ tcSimplifyDefault theta `thenTc` \ _ ->
returnTc default_ty
where
theta = [mkClassPred clas [default_ty] | clas <- classes]
-- Bind the type variable and reduce the context, for real this time
unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenTc_`
simpleReduceLoop (text "disambig" <+> ppr dicts)
- try_me dicts `thenTc` \ (frees, binds, ambigs) ->
+ reduceMe dicts `thenTc` \ (frees, binds, ambigs) ->
WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs )
warnDefault dicts chosen_default_ty `thenTc_`
returnTc binds
returnTc EmptyMonoBinds
where
- 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 :: ThetaType -- Wanted
- -> TcM ThetaType -- Needed
-
-tcSimplifyThetas wanteds
- = doptsTc Opt_GlasgowExts `thenNF_Tc` \ glaExts ->
- reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
+tcSimplifyDeriv :: [TyVar]
+ -> ThetaType -- Wanted
+ -> TcM ThetaType -- Needed
+
+tcSimplifyDeriv tyvars theta
+ = tcInstTyVars VanillaTv tyvars `thenNF_Tc` \ (tvs, _, tenv) ->
+ -- The main loop may do unification, and that may crash if
+ -- it doesn't see a TcTyVar, so we have to instantiate. Sigh
+ -- ToDo: what if two of them do get unified?
+ newDicts DataDeclOrigin (substTheta tenv theta) `thenNF_Tc` \ wanteds ->
+ simpleReduceLoop doc reduceMe wanteds `thenTc` \ (frees, _, irreds) ->
+ ASSERT( null frees ) -- reduceMe never returns Free
+
+ doptsTc Opt_AllowUndecidableInstances `thenNF_Tc` \ undecidable_ok ->
let
- -- For multi-param Haskell, check that the returned dictionaries
- -- don't have any of the form (C Int Bool) for which
- -- 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 = [pred | pred <- irreds,
- isEmptyVarSet (tyVarsOfPred pred)]
- | otherwise = [pred | pred <- irreds,
- not (isTyVarClassPred pred)]
+ tv_set = mkVarSet tvs
+ simpl_theta = map dictPred irreds -- reduceMe squashes all non-dicts
+
+ check_pred pred
+ | isEmptyVarSet pred_tyvars -- Things like (Eq T) should be rejected
+ = addErrTc (noInstErr pred)
+
+ | not undecidable_ok && not (isTyVarClassPred pred)
+ -- Check that the returned dictionaries are all of form (C a b)
+ -- (where a, b are type variables).
+ -- We allow this if we had -fallow-undecidable-instances,
+ -- but note that risks non-termination in the 'deriving' context-inference
+ -- fixpoint loop. It is useful for situations like
+ -- data Min h a = E | M a (h a)
+ -- which gives the instance decl
+ -- instance (Eq a, Eq (h a)) => Eq (Min h a)
+ = addErrTc (noInstErr pred)
+
+ | not (pred_tyvars `subVarSet` tv_set)
+ -- Check for a bizarre corner case, when the derived instance decl should
+ -- have form instance C a b => D (T a) where ...
+ -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
+ -- of problems; in particular, it's hard to compare solutions for
+ -- equality when finding the fixpoint. So I just rule it out for now.
+ = addErrTc (badDerivedPred pred)
+
+ | otherwise
+ = returnNF_Tc ()
+ where
+ pred_tyvars = tyVarsOfPred pred
+
+ rev_env = mkTopTyVarSubst tvs (mkTyVarTys tyvars)
+ -- This reverse-mapping is a Royal Pain,
+ -- but the result should mention TyVars not TcTyVars
in
- if null bad_guys then
- returnTc irreds
- else
- mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
- failTc
+
+ mapNF_Tc check_pred simpl_theta `thenNF_Tc_`
+ checkAmbiguity tvs simpl_theta tv_set `thenTc_`
+ returnTc (substTheta rev_env simpl_theta)
+ where
+ doc = ptext SLIT("deriving classes for a data type")
\end{code}
-@tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
+@tcSimplifyDefault@ just checks class-type constraints, essentially;
used with \tr{default} declarations. We are only interested in
whether it worked or not.
\begin{code}
-tcSimplifyCheckThetas :: ThetaType -- Given
- -> ThetaType -- Wanted
- -> TcM ()
-
-tcSimplifyCheckThetas givens wanteds
- = reduceSimple givens wanteds `thenNF_Tc` \ irreds ->
+tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it
+ -> TcM ()
+
+tcSimplifyDefault theta
+ = newDicts DataDeclOrigin theta `thenNF_Tc` \ wanteds ->
+ simpleReduceLoop doc reduceMe wanteds `thenTc` \ (frees, _, irreds) ->
+ ASSERT( null frees ) -- try_me never returns Free
+ mapNF_Tc (addErrTc . noInstErr) irreds `thenNF_Tc_`
if null irreds then
- returnTc ()
+ returnTc ()
else
- mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
- failTc
-\end{code}
-
-
-\begin{code}
-type AvailsSimple = FiniteMap PredType Bool
- -- True => irreducible
- -- False => given, or can be derived from a given or from an 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 [pred | (pred,True) <- fmToList givens_fm']
- where
- givens_fm = foldl addNonIrred emptyFM givens
-
-reduce_simple :: (Int,ThetaType) -- Stack
- -> AvailsSimple
- -> ThetaType
- -> NF_TcM AvailsSimple
-
-reduce_simple (n,stack) avails wanteds
- = go avails wanteds
+ failTc
where
- go avails [] = returnNF_Tc avails
- 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
- | wanted `elemFM` givens
- = returnNF_Tc givens
-
- | 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
-
- | otherwise
- = returnNF_Tc (addSimpleIrred givens wanted)
-
-addSimpleIrred :: AvailsSimple -> PredType -> AvailsSimple
-addSimpleIrred givens pred
- = addSCs (addToFM givens pred True) pred
-
-addNonIrred :: AvailsSimple -> PredType -> AvailsSimple
-addNonIrred givens pred
- = addSCs (addToFM givens pred False) pred
-
-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 = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
-
- add givens ct
- = case lookupFM givens ct of
- Nothing -> -- Add it and its superclasses
- addSCs (addToFM givens ct False) ct
-
- Just True -> -- Set its flag to False; superclasses already done
- addToFM givens ct False
-
- Just False -> -- Already done
- givens
-
+ doc = ptext SLIT("default declaration")
\end{code}
-- the given set as an optimisation
addNoInstanceErrs what_doc givens dicts
- = tcGetInstEnv `thenNF_Tc` \ inst_env ->
+ = getDOptsTc `thenNF_Tc` \ dflags ->
+ tcGetInstEnv `thenNF_Tc` \ inst_env ->
let
(tidy_env1, tidy_givens) = tidyInsts givens
(tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts
ambig_overlap = any ambig_overlap1 dicts
ambig_overlap1 dict
| isClassDict dict
- = case lookupInstEnv inst_env clas tys of
+ = case lookupInstEnv dflags inst_env clas tys of
NoMatch ambig -> ambig
other -> False
| otherwise = False
addInstErrTcM (instLoc (head dicts)) (tidy_env2, doc)
-- Used for the ...Thetas variants; all top level
-addNoInstErr pred
- = addErrTc (ptext SLIT("No instance for") <+> quotes (ppr pred))
+noInstErr pred = ptext SLIT("No instance for") <+> quotes (ppr pred)
+
+badDerivedPred pred
+ = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
+ ptext SLIT("type variables that are not data type parameters"),
+ nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,