X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=737999308f87e41b36a6984f93dfc7bf40557bf0;hp=4cb32b8a0fbf5cf367daf8dd4f3cb1f326ea074e;hb=e6d057711f4d6d6ff6342c39fa2b9e44d25447f1;hpb=7f0ce617a0380339da927433dc816e45704db0be diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 4cb32b8..7379993 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -21,19 +21,19 @@ module TcSimplify ( #include "HsVersions.h" import {-# SOURCE #-} TcUnify( unifyType ) -import TypeRep ( Type(..) ) -import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds ) -import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp ) +import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, mkWpTyApps, + HsWrapper(..), (<.>), nlHsTyApp, emptyLHsBinds ) +import TcHsSyn ( mkHsApp ) import TcRnMonad import Inst ( lookupInst, LookupInstResult(..), - tyVarsOfInst, fdPredsOfInsts, newDicts, + tyVarsOfInst, fdPredsOfInsts, isDict, isClassDict, isLinearInst, linearInstType, isMethodFor, isMethod, instToId, tyVarsOfInsts, cloneDict, ipNamesOfInsts, ipNamesOfInst, dictPred, - fdPredsOfInst, - newDictsAtLoc, tcInstClassOp, + fdPredsOfInst, + newDictBndrs, newDictBndrsO, tcInstClassOp, getDictClassTys, isTyVarDict, instLoc, zonkInst, tidyInsts, tidyMoreInsts, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs, @@ -71,8 +71,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} @@ -86,6 +87,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 @@ -257,9 +276,9 @@ any other type variables. - -------------------------------------- - Notes on ambiguity - -------------------------------------- +------------------------------------- + Note [Ambiguity] +------------------------------------- It's very hard to be certain when a type is ambiguous. Consider @@ -754,7 +773,7 @@ isFreeWhenChecking qtvs ips inst = isFreeWrtTyVars qtvs inst && isFreeWrtIPs ips inst -isFreeWrtTyVars qtvs inst = not (tyVarsOfInst inst `intersectsVarSet` qtvs) +isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst)) \end{code} @@ -922,7 +941,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) @@ -1047,8 +1067,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 @@ -1057,25 +1075,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 @@ -1089,7 +1112,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 @@ -1100,14 +1123,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} @@ -1446,6 +1469,7 @@ extractResults avails wanteds new_binds = addBind binds w rhs new_avails = addToFM avails w (LinRhss rhss) + -- get_root is just used for Linear get_root irreds frees (Given id _) w = returnM (irreds, frees, id) get_root irreds frees Irred w = cloneDict w `thenM` \ w' -> returnM (w':irreds, frees, instToId w') @@ -1518,7 +1542,7 @@ split n split_id root_id wanted returnM (L span (VarBind x (mk_app span split_id rhs)), [mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x]) -mk_fs_app span id ty var = L span (HsVar id) `mkHsTyApp` [ty,ty] `mkHsApp` (L span (HsVar var)) +mk_fs_app span id ty var = nlHsTyApp id [ty,ty] `mkHsApp` (L span (HsVar var)) mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs) @@ -1715,22 +1739,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 @@ -1889,7 +1912,7 @@ addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails -- Invariant: the Inst is already in Avails. addSCs is_loop avails dict - = do { sc_dicts <- newDictsAtLoc (instLoc dict) sc_theta' + = do { sc_dicts <- newDictBndrs (instLoc dict) sc_theta' ; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) } where (clas, tys) = getDictClassTys dict @@ -1901,7 +1924,8 @@ addSCs is_loop avails dict | is_given sc_dict = return avails | otherwise = addSCs is_loop avails' sc_dict where - sc_sel_rhs = mkHsDictApp (mkHsTyApp (L (instSpan dict) (HsVar sc_sel)) tys) [instToId dict] + sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel)) + co_fn = WpApp (instToId dict) <.> mkWpTyApps tys avails' = addToFM avails sc_dict (Rhs sc_sel_rhs [dict]) is_given :: Inst -> Bool @@ -2011,7 +2035,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" @@ -2022,7 +2047,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)) @@ -2045,16 +2070,16 @@ tc_simplify_top doc is_interactive want_scs wanteds -- up with one of the non-tyvar classes (default_gps, non_default_gps) = partition defaultable_group tv_groups defaultable_group ds - = not (bad_tyvars `intersectsVarSet` tyVarsOfInst (head ds)) + = (bad_tyvars `disjointVarSet` 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 @@ -2254,7 +2279,7 @@ tcSimplifyDeriv tc tyvars theta -- 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 DerivOrigin (substTheta tenv theta) `thenM` \ wanteds -> + newDictBndrsO DerivOrigin (substTheta tenv theta) `thenM` \ wanteds -> simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) -> ASSERT( null frees ) -- reduceMe never returns Free @@ -2300,7 +2325,7 @@ tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it -> TcM () tcSimplifyDefault theta - = newDicts DefaultOrigin theta `thenM` \ wanteds -> + = newDictBndrsO DefaultOrigin theta `thenM` \ wanteds -> simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) -> ASSERT( null frees ) -- try_me never returns Free addNoInstanceErrs Nothing [] irreds `thenM_` @@ -2450,8 +2475,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 @@ -2508,7 +2533,7 @@ monomorphism_fix = ptext SLIT("Probable fix:") <+> warnDefault dicts default_ty = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag -> - addInstCtxt (instLoc (head dicts)) (warnTc warn_flag warn_msg) + addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg) where -- Tidy them first (_, tidy_dicts) = tidyInsts dicts @@ -2524,7 +2549,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)