X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=c0bb23bc47fbd7b78353bee3bb0de58d51d048af;hb=44ba24dc84d271ca9bd5ab5060cb63ed87f585e3;hp=3c8160cbcbc459083738f8b4141981be398bb9d6;hpb=2ed6929441ca033f2c5e1cf1a836579fff30b073;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 3c8160c..c0bb23b 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, @@ -86,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 @@ -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 @@ -1048,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 @@ -1058,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 @@ -1090,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 @@ -1101,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} @@ -1447,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') @@ -1519,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) @@ -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) (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 @@ -2509,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