X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=1998cd2bc467b3aee682ac9fc47ca1bb646b4939;hb=c76c69c5b62f1ca4fa52d75b0dfbd37b7eddbb09;hp=19557c6dd7e21e2268a05219aa18b0ab250a80b4;hpb=5a8a219c131b56c75dbb3110da3ab5ae3715ff66;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 19557c6..1998cd2 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -21,7 +21,6 @@ module TcSimplify ( #include "HsVersions.h" import {-# SOURCE #-} TcUnify( unifyType ) -import TypeRep ( Type(..) ) import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds ) import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp ) @@ -42,8 +41,7 @@ import Inst ( lookupInst, LookupInstResult(..), import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders, lclEnvElts, tcMetaTy ) import InstEnv ( lookupInstEnv, classInstances, pprInstances ) -import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType, - checkAmbiguity, checkInstTermination ) +import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType ) import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred, mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar, mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys, @@ -72,8 +70,9 @@ import ListSetOps ( equivClasses ) import Util ( zipEqual, isSingleton ) import List ( partition ) import SrcLoc ( Located(..) ) -import DynFlags ( DynFlag(..) ) -import StaticFlags +import DynFlags ( DynFlags(ctxtStkDepth), + DynFlag( Opt_GlasgowExts, Opt_AllowUndecidableInstances, + Opt_WarnTypeDefaults, Opt_ExtendedDefaultRules ) ) \end{code} @@ -87,6 +86,24 @@ import StaticFlags Notes on functional dependencies (a bug) -------------------------------------- +Consider this: + + class C a b | a -> b + class D a b | a -> b + + instance D a b => C a b -- Undecidable + -- (Not sure if it's crucial to this eg) + f :: C a b => a -> Bool + f _ = True + + g :: C a b => a -> Bool + g = f + +Here f typechecks, but g does not!! Reason: before doing improvement, +we reduce the (C a b1) constraint from the call of f to (D a b1). + +Here is a more complicated example: + | > class Foo a b | a->b | > | > class Bar a b | a->b @@ -258,9 +275,9 @@ any other type variables. - -------------------------------------- - Notes on ambiguity - -------------------------------------- +------------------------------------- + Note [Ambiguity] +------------------------------------- It's very hard to be certain when a type is ambiguous. Consider @@ -923,7 +940,8 @@ Two more nasty cases are in tcSimplifySuperClasses qtvs givens sc_wanteds = ASSERT( all isSkolemTyVar qtvs ) do { (_, frees, binds1) <- tcSimplCheck doc get_qtvs NoSCs givens sc_wanteds - ; binds2 <- tc_simplify_top doc False NoSCs frees + ; ext_default <- doptM Opt_ExtendedDefaultRules + ; binds2 <- tc_simplify_top doc ext_default NoSCs frees ; return (binds1 `unionBags` binds2) } where get_qtvs = return (mkVarSet qtvs) @@ -1048,8 +1066,6 @@ tcSimplifyRestricted -- Used for restricted binding groups tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- Zonk everything in sight = mappM zonkInst wanteds `thenM` \ wanteds' -> - zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' -> - tcGetGlobalTyVars `thenM` \ gbl_tvs' -> -- 'reduceMe': Reduce as far as we can. Don't stop at -- dicts; the idea is to get rid of as many type @@ -1058,25 +1074,30 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- 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 reduceContextWithoutImprovement doc reduceMe wanteds' `thenM` \ (_frees, _binds, constrained_dicts) -> -- Next, figure out the tyvars we will quantify over + zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' -> + tcGetGlobalTyVars `thenM` \ gbl_tvs' -> + mappM zonkInst constrained_dicts `thenM` \ constrained_dicts' -> let - constrained_tvs = tyVarsOfInsts constrained_dicts - qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs') - `minusVarSet` constrained_tvs + constrained_tvs' = tyVarsOfInsts constrained_dicts' + qtvs' = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs') + `minusVarSet` constrained_tvs' in traceTc (text "tcSimplifyRestricted" <+> vcat [ - pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts, + pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts', ppr _binds, - ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_` + ppr constrained_tvs', ppr tau_tvs', ppr qtvs' ]) `thenM_` -- 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; + -- 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 @@ -1090,7 +1111,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- expose implicit parameters to the test that follows let is_nested_group = isNotTopLevel top_lvl - try_me inst | isFreeWrtTyVars qtvs inst, + try_me inst | isFreeWrtTyVars qtvs' inst, (is_nested_group || isDict inst) = Free | otherwise = ReduceMe AddSCs in @@ -1101,14 +1122,14 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- See "Notes on implicit parameters, Question 4: top level" if is_nested_group then extendLIEs frees `thenM_` - returnM (varSetElems qtvs, binds) + returnM (varSetElems qtvs', binds) else let (non_ips, bad_ips) = partition isClassDict frees in addTopIPErrs bndrs bad_ips `thenM_` extendLIEs non_ips `thenM_` - returnM (varSetElems qtvs, binds) + returnM (varSetElems qtvs', binds) \end{code} @@ -1716,22 +1737,21 @@ I had to produce Y, to produce Y I had to produce Z, and so on. \begin{code} reduceList (n,stack) try_me wanteds state - | n > opt_MaxContextReductionDepth - = failWithTc (reduceDepthErr n stack) - - | otherwise - = + = do { dopts <- getDOpts #ifdef DEBUG - (if n > 8 then - pprTrace "Interesting! Context reduction stack deeper than 8:" - (int n $$ ifPprDebug (nest 2 (pprStack stack))) - else (\x->x)) + ; if n > 8 then + dumpTcRn (text "Interesting! Context reduction stack deeper than 8:" + <+> (int n $$ ifPprDebug (nest 2 (pprStack stack)))) + else return () #endif - go wanteds state + ; if n >= ctxtStkDepth dopts then + failWithTc (reduceDepthErr n stack) + else + go wanteds state } where - go [] state = returnM state - go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenM` \ state' -> - go ws state' + go [] state = return state + go (w:ws) state = do { state' <- reduce (n+1, w:stack) try_me w state + ; go ws state' } -- Base case: we're done! reduce stack try_me wanted avails @@ -2012,7 +2032,8 @@ It's OK: the final zonking stage should zap y to (), which is fine. \begin{code} tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds tcSimplifyTop wanteds - = tc_simplify_top doc False {- Not interactive loop -} AddSCs wanteds + = do { ext_default <- doptM Opt_ExtendedDefaultRules + ; tc_simplify_top doc ext_default AddSCs wanteds } where doc = text "tcSimplifyTop" @@ -2023,7 +2044,7 @@ tcSimplifyInteractive wanteds -- The TcLclEnv should be valid here, solely to improve -- error message generation for the monomorphism restriction -tc_simplify_top doc is_interactive want_scs wanteds +tc_simplify_top doc use_extended_defaulting want_scs wanteds = do { lcl_env <- getLclEnv ; traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) @@ -2049,13 +2070,13 @@ tc_simplify_top doc is_interactive want_scs wanteds = not (bad_tyvars `intersectsVarSet` tyVarsOfInst (head ds)) && defaultable_classes (map get_clas ds) defaultable_classes clss - | is_interactive = any isInteractiveClass clss - | otherwise = all isStandardClass clss && any isNumericClass clss + | use_extended_defaulting = any isInteractiveClass clss + | otherwise = all isStandardClass clss && any isNumericClass clss isInteractiveClass cls = isNumericClass cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey]) - -- In interactive mode, we default Show a to Show () - -- to avoid graututious errors on "show []" + -- In interactive mode, or with -fextended-default-rules, + -- we default Show a to Show () to avoid graututious errors on "show []" -- Collect together all the bad guys @@ -2283,19 +2304,10 @@ tcSimplifyDeriv tc tyvars 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") @@ -2460,8 +2472,8 @@ addNoInstanceErrs mb_what givens dicts ptext SLIT("to the") <+> what] ] fix2 | null instance_dicts = [] - | otherwise = [ ptext SLIT("add an instance declaration for") - <+> pprDictsTheta instance_dicts ] + | otherwise = [ sep [ptext SLIT("add an instance declaration for"), + pprDictsTheta instance_dicts] ] instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)] -- Insts for which it is worth suggesting an adding an instance declaration -- Exclude implicit parameters, and tyvar dicts @@ -2534,7 +2546,7 @@ badDerivedPred pred reduceDepthErr n stack = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n, - ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"), + ptext SLIT("Use -fcontext-stack=N to increase stack size to N"), nest 4 (pprStack stack)] pprStack stack = vcat (map pprInstInFull stack)