#include "HsVersions.h"
-import {-# SOURCE #-} TcUnify( unifyTauTy )
+import {-# SOURCE #-} TcUnify( unifyType )
+import TypeRep ( Type(..) )
import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
ipNamesOfInsts, ipNamesOfInst, dictPred,
- instBindingRequired, fdPredsOfInst,
+ fdPredsOfInst,
newDictsAtLoc, tcInstClassOp,
getDictClassTys, isTyVarDict, instLoc,
zonkInst, tidyInsts, tidyMoreInsts,
import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders,
lclEnvElts, tcMetaTy )
import InstEnv ( lookupInstEnv, classInstances, pprInstances )
-import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
-import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType,
+import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType,
+ checkAmbiguity, checkInstTermination )
+import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred,
mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
tyVarsOfPred, tcEqType, pprPred, mkPredTy, tcIsTyVarTy )
import TcIface ( checkWiredInTyCon )
import Id ( idType, mkUserLocal )
import Var ( TyVar )
+import TyCon ( TyCon )
import Name ( Name, getOccName, getSrcLoc )
import NameSet ( NameSet, mkNameSet, elemNameSet )
import Class ( classBigSig, classKey )
-import FunDeps ( oclose, grow, improve, pprEquationDoc )
+import FunDeps ( oclose, grow, improve, pprEquation )
import PrelInfo ( isNumericClass, isStandardClass )
import PrelNames ( splitName, fstName, sndName, integerTyConName,
showClassKey, eqClassKey, ordClassKey )
-- e.g. those "given" in a signature
Bool -- True <=> actually consumed (splittable IPs only)
- | NoRhs -- Used for Insts like (CCallable f)
- -- where no witness is required.
- -- ToDo: remove?
-
| Rhs -- Used when there is a RHS
(LHsExpr TcId) -- The RHS
[Inst] -- Insts free in the RHS; we need these too
instance Outputable Avail where
ppr = pprAvail
-pprAvail NoRhs = text "<no rhs>"
pprAvail IsFree = text "Free"
pprAvail Irred = text "Irred"
pprAvail (Given x b) = text "Given" <+> ppr x <+>
Nothing -> pprTrace "Urk: extractResults" (ppr w) $
go avails binds irreds frees ws
- Just NoRhs -> go avails binds irreds frees ws
Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws
Just Irred -> go (add_given avails w) binds (w:irreds) frees ws
get_root irreds frees IsFree w = cloneDict w `thenM` \ w' ->
returnM (irreds, w':frees, instToId w')
- add_given avails w
- | instBindingRequired w = addToFM avails w (Given (instToId w) True)
- | otherwise = addToFM avails w NoRhs
- -- NB: make sure that CCallable/CReturnable use NoRhs rather
- -- than Given, else we end up with bogus bindings.
+ add_given avails w = addToFM avails w (Given (instToId w) True)
add_free avails w | isMethod w = avails
| otherwise = add_given avails w
mappM_ unify eqns `thenM_`
returnM False
where
- unify ((qtvs, pairs), doc)
- = addErrCtxt doc $
+ unify ((qtvs, pairs), what1, what2)
+ = addErrCtxtM (mkEqnMsg what1 what2) $
tcInstTyVars (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
mapM_ (unif_pr tenv) pairs
- unif_pr tenv (ty1,ty2) = unifyTauTy (substTy tenv ty1) (substTy tenv ty2)
+ unif_pr tenv (ty1,ty2) = unifyType (substTy tenv ty1) (substTy tenv ty2)
+
+pprEquationDoc (eqn, (p1,w1), (p2,w2)) = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
+
+mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
+ = do { pred1' <- zonkTcPredType pred1; pred2' <- zonkTcPredType pred2
+ ; let { pred1'' = tidyPred tidy_env pred1'; pred2'' = tidyPred tidy_env pred2' }
+ ; let msg = vcat [ptext SLIT("When using functional dependencies to combine"),
+ nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]),
+ nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
+ ; return (tidy_env, msg) }
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
#ifdef DEBUG
(if n > 8 then
pprTrace "Interesting! Context reduction stack deeper than 8:"
- (nest 2 (pprStack stack))
+ (int n $$ ifPprDebug (nest 2 (pprStack stack)))
else (\x->x))
#endif
go wanteds state
addWanted want_scs avails wanted rhs_expr wanteds
= addAvailAndSCs want_scs avails wanted avail
where
- avail | instBindingRequired wanted = Rhs rhs_expr wanteds
- | otherwise = ASSERT( null wanteds ) NoRhs
+ avail = Rhs rhs_expr wanteds
addGiven :: Avails -> Inst -> TcM Avails
addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given) False)
choose_default default_ty -- Commit to tyvar = default_ty
= -- Bind the type variable
- unifyTauTy default_ty (mkTyVarTy tyvar) `thenM_`
+ unifyType default_ty (mkTyVarTy tyvar) `thenM_`
-- and reduce the context, for real this time
simpleReduceLoop (text "disambig" <+> ppr dicts)
reduceMe dicts `thenM` \ (frees, binds, ambigs) ->
When typechecking _ccall_s, TcExpr ensures that the external
function is only passed arguments (and in the other direction,
-results) of a restricted set of 'native' types. This is
-implemented via the help of the pseudo-type classes,
-@CReturnable@ (CR) and @CCallable@ (CC.)
+results) of a restricted set of 'native' types.
The interaction between the defaulting mechanism for numeric
values and CC & CR can be a bit puzzling to the user at times.
Haskell 1.4's default-default of (Int, Double), 'x' has type
Int.
-To try to minimise the potential for surprises here, the
-defaulting mechanism is turned off in the presence of
-CCallable and CReturnable.
-
End of aside]
instance declarations.
\begin{code}
-tcSimplifyDeriv :: [TyVar]
+tcSimplifyDeriv :: TyCon
+ -> [TyVar]
-> ThetaType -- Wanted
-> TcM ThetaType -- Needed
-tcSimplifyDeriv tyvars theta
+tcSimplifyDeriv tc tyvars theta
= tcInstTyVars tyvars `thenM` \ (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
simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- reduceMe never returns Free
+ doptM Opt_GlasgowExts `thenM` \ gla_exts ->
doptM Opt_AllowUndecidableInstances `thenM` \ undecidable_ok ->
let
tv_set = mkVarSet tvs
= let pred = dictPred dict -- reduceMe squashes all non-dicts
in isEmptyVarSet (tyVarsOfPred pred)
-- Things like (Eq T) are bad
- || (not undecidable_ok && not (isTyVarClassPred pred))
- -- The returned dictionaries should be of form (C a b)
- -- (where a, b are type variables).
- -- We allow non-tyvar dicts 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)
+ || (not gla_exts && not (isTyVarClassPred pred))
simpl_theta = map dictPred ok_insts
weird_preds = [pred | pred <- simpl_theta
rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
-- This reverse-mapping is a Royal Pain,
-- but the result should mention TyVars not TcTyVars
+
+ head_ty = TyConApp tc (map TyVarTy tvs)
in
addNoInstanceErrs Nothing [] bad_insts `thenM_`
mapM_ (addErrTc . badDerivedPred) weird_preds `thenM_`
checkAmbiguity tvs simpl_theta tv_set `thenM_`
+ -- Check instance termination as for user-declared instances.
+ -- unless we had -fallow-undecidable-instances (which risks
+ -- non-termination in the 'deriving' context-inference fixpoint
+ -- loop).
+ ifM (gla_exts && not undecidable_ok)
+ (checkInstTermination simpl_theta [head_ty]) `thenM_`
returnM (substTheta rev_env simpl_theta)
where
doc = ptext SLIT("deriving classes for a data type")
= addErrTcM (tidy_env, mk_msg tidy_ips)
where
(tidy_env, tidy_ips) = tidyInsts ips
- mk_msg ips = vcat [sep [ptext SLIT("Implicit parameters escape from the monomorphic top-level binding(s) of"),
- pprBinders bndrs <> colon],
+ mk_msg ips = vcat [sep [ptext SLIT("Implicit parameters escape from"),
+ nest 2 (ptext SLIT("the monomorphic top-level binding(s) of")
+ <+> pprBinders bndrs <> colon)],
nest 2 (vcat (map ppr_ip ips)),
monomorphism_fix]
ppr_ip ip = pprPred (dictPred ip) <+> pprInstLoc (instLoc ip)
ispecs = [ispec | (_, ispec) <- matches]
mk_probable_fix tidy_env dicts
- = returnM (tidy_env, sep [ptext SLIT("Probable fix:"), nest 2 (vcat fixes)])
+ = returnM (tidy_env, sep [ptext SLIT("Possible fix:"), nest 2 (vcat fixes)])
where
fixes = add_ors (fix1 ++ fix2)
projects / ghc-hetmet.git / blobdiff