X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=8f062704aab839ae0b8a8dd79f0c781e04dc0764;hp=dae3c829118d6a26d07008498002333945225471;hb=3e83dfb21b2f2220dce97427fff5c19459ae68d1;hpb=bec18cb3a1dcbc70b0257a367091c9a5948da6f6 diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index dae3c82..8f06270 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -21,8 +21,9 @@ module TcSimplify ( #include "HsVersions.h" import {-# SOURCE #-} TcUnify( unifyType ) -import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds ) -import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp ) +import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, + ExprCoFn(..), (<.>), nlHsTyApp, emptyLHsBinds ) +import TcHsSyn ( mkHsApp ) import TcRnMonad import Inst ( lookupInst, LookupInstResult(..), @@ -31,7 +32,7 @@ import Inst ( lookupInst, LookupInstResult(..), isMethodFor, isMethod, instToId, tyVarsOfInsts, cloneDict, ipNamesOfInsts, ipNamesOfInst, dictPred, - fdPredsOfInst, + fdPredsOfInst, mkInstCoFn, newDictsAtLoc, tcInstClassOp, getDictClassTys, isTyVarDict, instLoc, zonkInst, tidyInsts, tidyMoreInsts, @@ -71,7 +72,8 @@ import Util ( zipEqual, isSingleton ) import List ( partition ) import SrcLoc ( Located(..) ) import DynFlags ( DynFlags(ctxtStkDepth), - DynFlag( Opt_GlasgowExts, Opt_AllowUndecidableInstances, Opt_WarnTypeDefaults ) ) + DynFlag( Opt_GlasgowExts, Opt_AllowUndecidableInstances, + Opt_WarnTypeDefaults, Opt_ExtendedDefaultRules ) ) \end{code} @@ -85,6 +87,24 @@ import DynFlags ( DynFlags(ctxtStkDepth), 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 @@ -256,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 @@ -921,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) @@ -1046,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 @@ -1056,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 @@ -1088,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 @@ -1099,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} @@ -1445,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') @@ -1517,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) @@ -1899,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) (HsCoerce co_fn (HsVar sc_sel)) + co_fn = mkInstCoFn tys [dict] avails' = addToFM avails sc_dict (Rhs sc_sel_rhs [dict]) is_given :: Inst -> Bool @@ -2009,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" @@ -2020,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)) @@ -2046,13 +2073,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 @@ -2448,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