X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=4c7f69d539c32403696e289650841d7d6b4e0322;hb=a170160cc21678c30ca90696d4ae0fc1155f25bf;hp=8af99244fd2ca9534b0665ae5584987b46166dff;hpb=32a895831dbc202fab780fdd8bee65be81e2d232;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 8af9924..4c7f69d 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -11,7 +11,7 @@ module TcSimplify ( tcSimplifyCheck, tcSimplifyRestricted, tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop, - tcSimplifyThetas, tcSimplifyCheckThetas, + tcSimplifyDeriv, tcSimplifyDefault, bindInstsOfLocalFuns ) where @@ -25,12 +25,12 @@ import TcHsSyn ( TcExpr, TcId, ) 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, @@ -40,19 +40,19 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), ) 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 ) @@ -635,7 +635,7 @@ The net effect of [NO TYVARS] 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 @@ -670,9 +670,14 @@ tcSimplifyCheck -- 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) -> @@ -1020,6 +1025,9 @@ data WhatToDo | 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} @@ -1056,7 +1064,7 @@ data Avail -- 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 @@ -1189,8 +1197,8 @@ split n split_id avail wanted 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 @@ -1307,8 +1315,8 @@ tcImprove avails 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} @@ -1413,7 +1421,7 @@ isAvailable avails wanted = lookupFM avails wanted 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]) @@ -1519,26 +1527,6 @@ than a selection. %************************************************************************ -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. @@ -1555,7 +1543,7 @@ It's OK: the final zonking stage should zap y to (), which is fine. \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 @@ -1590,7 +1578,6 @@ tcSimplifyTop wanted_lie 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 @@ -1600,6 +1587,26 @@ get_clas d = case getDictClassTys d of (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. @@ -1637,7 +1644,7 @@ disambigGroup dicts 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] @@ -1652,7 +1659,7 @@ disambigGroup dicts -- 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 @@ -1668,7 +1675,6 @@ disambigGroup dicts 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} @@ -1723,116 +1729,83 @@ a,b,c are type variables. This is required for the context of 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} @@ -1923,7 +1896,8 @@ complainCheck doc givens irreds -- 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 @@ -1968,7 +1942,7 @@ addNoInstanceErrs what_doc givens 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 @@ -1978,8 +1952,12 @@ addNoInstanceErrs what_doc givens dicts 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,