X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=7a971abcc699ce2a4566ae8fd0366ea65dcbecfd;hb=ac41c500b3769f005eeeaf964170a78c79135196;hp=1970ab387fa99f2e202f2f63b2116d4d160ad4bd;hpb=2129fa6fc4afd7f7b0c767f8c0c14b9ab5508ec2;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 1970ab3..7a971ab 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -37,11 +37,11 @@ import Inst ( lookupInst, LookupInstResult(..), newDictsFromOld, tcInstClassOp, getDictClassTys, isTyVarDict, instLoc, zonkInst, tidyInsts, tidyMoreInsts, - Inst, pprInsts, pprInstsInFull, - isIPDict, isInheritableInst + Inst, pprInsts, pprInstsInFull, tcGetInstEnvs, + isIPDict, isInheritableInst, pprDFuns ) -import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupId, findGlobals ) -import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) ) +import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals ) +import InstEnv ( lookupInstEnv, classInstEnv ) import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity ) import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv), mkClassPred, isOverloadedTy, mkTyConApp, @@ -54,18 +54,16 @@ import NameSet ( NameSet, mkNameSet, elemNameSet ) import Class ( classBigSig, classKey ) import FunDeps ( oclose, grow, improve, pprEquationDoc ) import PrelInfo ( isNumericClass ) -import PrelNames ( splitName, fstName, sndName, showClassKey, eqClassKey, ordClassKey) -import HscTypes ( GhciMode(Interactive) ) - +import PrelNames ( splitName, fstName, sndName, integerTyConName, + showClassKey, eqClassKey, ordClassKey ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) -import TysWiredIn ( unitTy, pairTyCon ) +import TysWiredIn ( pairTyCon, doubleTy ) import ErrUtils ( Message ) import VarSet import VarEnv ( TidyEnv ) import FiniteMap import Outputable import ListSetOps ( equivClasses ) -import Unique ( hasKey ) import Util ( zipEqual, isSingleton ) import List ( partition ) import CmdLineOpts @@ -729,13 +727,18 @@ tcSimplCheck doc get_qtvs givens wanted_lie = check_loop givens wanted_lie `thenM` \ (qtvs, frees, binds, irreds) -> -- Complain about any irreducible ones - complainCheck doc givens irreds `thenM_` + mappM zonkInst given_dicts_and_ips `thenM` \ givens' -> + groupErrs (addNoInstanceErrs (Just doc) givens') irreds `thenM_` -- Done - extendLIEs frees `thenM_` + extendLIEs frees `thenM_` returnM (qtvs, binds) where + given_dicts_and_ips = filter (not . isMethod) givens + -- For error reporting, filter out methods, which are + -- only added to the given set as an optimisation + ip_set = mkNameSet (ipNamesOfInsts givens) check_loop givens wanteds @@ -1328,8 +1331,10 @@ reduceContext doc try_me givens wanteds returnM (no_improvement, frees, binds, irreds) +tcImprove :: Avails -> TcM Bool -- False <=> no change +-- Perform improvement using all the predicates in Avails tcImprove avails - = tcGetInstEnv `thenM` \ inst_env -> + = tcGetInstEnvs `thenM` \ (home_ie, pkg_ie) -> let preds = [ (pred, pp_loc) | inst <- keysFM avails, @@ -1341,7 +1346,8 @@ tcImprove avails -- It does not have duplicates (good) -- NB that (?x::t1) and (?x::t2) will be held separately in avails -- so that improve will see them separate - eqns = improve (classInstEnv inst_env) preds + eqns = improve get_insts preds + get_insts clas = classInstEnv home_ie clas ++ classInstEnv pkg_ie clas in if null eqns then returnM True @@ -1523,7 +1529,8 @@ addIrred AddSCs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $ addAvailAndSCs :: Avails -> Inst -> Avail -> TcM Avails addAvailAndSCs avails inst avail | not (isClassDict inst) = returnM avails1 - | otherwise = addSCs is_loop avails1 inst + | otherwise = traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps]) `thenM_` + addSCs is_loop avails1 inst where avails1 = addToFM avails inst avail is_loop inst = inst `elem` deps -- Note: this compares by *type*, not by Unique @@ -1556,13 +1563,13 @@ addSCs is_loop avails dict sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses + | is_loop sc_dict + = returnM avails -- See Note [SUPERCLASS-LOOP] + | otherwise = case lookupFM avails sc_dict of - Just (Given _ _) -> returnM avails -- Given is cheaper than - -- a superclass selection - Just other | is_loop sc_dict -> returnM avails -- See Note [SUPERCLASS-LOOP] - | otherwise -> returnM avails' -- SCs already added - - Nothing -> addSCs is_loop avails' sc_dict + Just (Given _ _) -> returnM avails -- Given is cheaper than superclass selection + Just other -> returnM avails' -- SCs already added + Nothing -> addSCs is_loop avails' sc_dict where sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict] avail = Rhs sc_sel_rhs [dict] @@ -1582,6 +1589,14 @@ superclasses of C [a] to avails. But we must not overwrite the binding for d1:Ord a (which is given) with a superclass selection or we'll just build a loop! +Here's another variant, immortalised in tcrun020 + class Monad m => C1 m + class C1 m => C2 m x + instance C2 Maybe Bool +For the instance decl we need to build (C1 Maybe), and it's no good if +we run around and add (C2 Maybe Bool) and its superclasses to the avails +before we search for C1 Maybe. + Here's another example class Eq b => Foo a b instance Eq a => Foo [a] a @@ -1689,8 +1704,7 @@ tc_simplify_top is_interactive wanteds -- Collect together all the bad guys bad_guys = non_stds ++ concat std_bads - (tidy_env, tidy_dicts) = tidyInsts bad_guys - (bad_ips, non_ips) = partition isIPDict tidy_dicts + (bad_ips, non_ips) = partition isIPDict bad_guys (no_insts, ambigs) = partition no_inst non_ips no_inst d = not (isTyVarDict d) -- Previously, there was a more elaborate no_inst definition: @@ -1701,8 +1715,8 @@ tc_simplify_top is_interactive wanteds in -- Report definite errors - addTopInstanceErrs tidy_env no_insts `thenM_` - addTopIPErrs tidy_env bad_ips `thenM_` + groupErrs (addNoInstanceErrs Nothing []) no_insts `thenM_` + addTopIPErrs bad_ips `thenM_` -- Deal with ambiguity errors, but only if -- if there has not been an error so far; errors often @@ -1715,7 +1729,7 @@ tc_simplify_top is_interactive wanteds -- e.g. Num (IO a) and Eq (Int -> Int) -- and ambiguous dictionaries -- e.g. Num a - addTopAmbigErrs (tidy_env, ambigs) `thenM_` + addTopAmbigErrs ambigs `thenM_` -- Disambiguate the ones that look feasible mappM (disambigGroup is_interactive) std_oks @@ -1778,7 +1792,7 @@ disambigGroup is_interactive dicts -- default list which can satisfy all the ambiguous classes. -- For example, if Real a is reqd, but the only type in the -- default list is Int. - getDefaultTys `thenM` \ default_tys -> + get_default_tys `thenM` \ default_tys -> let try_default [] -- No defaults work, so fail = failM @@ -1821,8 +1835,17 @@ disambigGroup is_interactive dicts warnDefault dicts default_ty `thenM_` returnM binds - bomb_out = addTopAmbigErrs (tidyInsts dicts) `thenM_` + bomb_out = addTopAmbigErrs dicts `thenM_` returnM EmptyMonoBinds + +get_default_tys + = do { mb_defaults <- getDefaultTys + ; case mb_defaults of + Just tys -> return tys + Nothing -> -- No use-supplied default; + -- use [Integer, Double] + do { integer_ty <- tcMetaTy integerTyConName + ; return [integer_ty, doubleTy] } } \end{code} [Aside - why the defaulting mechanism is turned off when @@ -1995,28 +2018,89 @@ addInstLoc insts msg = msg $$ nest 2 (pprInstLoc (instLoc (head insts))) plural [x] = empty plural xs = char 's' - -addTopIPErrs tidy_env tidy_dicts +addTopIPErrs dicts = groupErrs report tidy_dicts where + (tidy_env, tidy_dicts) = tidyInsts dicts report dicts = addErrTcM (tidy_env, mk_msg dicts) mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <> plural tidy_dicts <+> pprInsts tidy_dicts) --- Used for top-level irreducibles -addTopInstanceErrs tidy_env tidy_dicts - = groupErrs report tidy_dicts +addNoInstanceErrs :: Maybe SDoc -- Nothing => top level + -- Just d => d describes the construct + -> [Inst] -- What is given by the context or type sig + -> [Inst] -- What is wanted + -> TcM () +addNoInstanceErrs mb_what givens [] + = returnM () +addNoInstanceErrs mb_what givens dicts + = -- Some of the dicts are here because there is no instances + -- and some because there are too many instances (overlap) + -- The first thing we do is separate them + getDOpts `thenM` \ dflags -> + tcGetInstEnvs `thenM` \ inst_envs -> + let + (tidy_env1, tidy_givens) = tidyInsts givens + (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts + + -- Run through the dicts, generating a message for each + -- overlapping one, but simply accumulating all the + -- no-instance ones so they can be reported as a group + (overlap_doc, no_inst_dicts) = foldl check_overlap (empty, []) tidy_dicts + check_overlap (overlap_doc, no_inst_dicts) dict + | not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts) + | otherwise + = case lookupInstEnv dflags inst_envs clas tys of + ([], _) -> (overlap_doc, dict : no_inst_dicts) -- No matches + inst_res -> (mk_overlap_msg dict inst_res $$ overlap_doc, no_inst_dicts) + where + (clas,tys) = getDictClassTys dict + in + mk_probable_fix tidy_env2 mb_what no_inst_dicts `thenM` \ (tidy_env3, probable_fix) -> + let + no_inst_doc | null no_inst_dicts = empty + | otherwise = vcat [addInstLoc no_inst_dicts heading, probable_fix] + heading | null givens = ptext SLIT("No instance") <> plural no_inst_dicts <+> + ptext SLIT("for") <+> pprInsts no_inst_dicts + | otherwise = sep [ptext SLIT("Could not deduce") <+> pprInsts no_inst_dicts, + nest 2 $ ptext SLIT("from the context") <+> pprInsts tidy_givens] + in + addErrTcM (tidy_env3, no_inst_doc $$ overlap_doc) + where - report dicts = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) -> - addErrTcM (tidy_env, mk_msg dicts $$ mono_msg) - mk_msg dicts = addInstLoc dicts (ptext SLIT("No instance") <> plural tidy_dicts <+> - ptext SLIT("for") <+> pprInsts tidy_dicts) - + mk_overlap_msg dict (matches, unifiers) + = vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for") <+> ppr dict)), + sep [ptext SLIT("Matching instances") <> colon, + nest 2 (pprDFuns (dfuns ++ unifiers))], + if null unifiers + then empty + else parens (ptext SLIT("The choice depends on the instantiation of") <+> + quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))))] + where + dfuns = [df | (_, (_,_,df)) <- matches] -addTopAmbigErrs (tidy_env, tidy_dicts) + mk_probable_fix tidy_env Nothing dicts -- Top level + = mkMonomorphismMsg tidy_env dicts + mk_probable_fix tidy_env (Just what) dicts -- Nested (type signatures, instance decls) + = returnM (tidy_env, sep [ptext SLIT("Probable fix:"), nest 2 fix1, nest 2 fix2]) + where + fix1 = sep [ptext SLIT("Add") <+> pprInsts dicts, + ptext SLIT("to the") <+> what] + + fix2 | null instance_dicts = empty + | otherwise = ptext SLIT("Or add an instance declaration for") + <+> pprInsts 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 + + +addTopAmbigErrs dicts -- Divide into groups that share a common set of ambiguous tyvars = mapM report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts]) where + (tidy_env, tidy_dicts) = tidyInsts dicts + tvs_of :: Inst -> [TcTyVar] tvs_of d = varSetElems (tyVarsOfInst d) cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 @@ -2066,72 +2150,6 @@ warnDefault dicts default_ty quotes (ppr default_ty), pprInstsInFull tidy_dicts] -complainCheck doc givens irreds - = mappM zonkInst given_dicts_and_ips `thenM` \ givens' -> - groupErrs (addNoInstanceErrs doc givens') irreds `thenM_` - returnM () - where - given_dicts_and_ips = filter (not . isMethod) givens - -- Filter out methods, which are only added to - -- the given set as an optimisation - -addNoInstanceErrs what_doc givens dicts - = getDOpts `thenM` \ dflags -> - tcGetInstEnv `thenM` \ inst_env -> - let - (tidy_env1, tidy_givens) = tidyInsts givens - (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts - - doc = vcat [addInstLoc dicts $ - sep [herald <+> pprInsts tidy_dicts, - nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens], - ambig_doc, - ptext SLIT("Probable fix:"), - nest 4 fix1, - nest 4 fix2] - - herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce") - unambig_doc | ambig_overlap = ptext SLIT("unambiguously") - | otherwise = empty - - -- The error message when we don't find a suitable instance - -- is complicated by the fact that sometimes this is because - -- there is no instance, and sometimes it's because there are - -- too many instances (overlap). See the comments in TcEnv.lhs - -- with the InstEnv stuff. - - ambig_doc - | not ambig_overlap = empty - | otherwise - = vcat [ptext SLIT("The choice of (overlapping) instance declaration"), - nest 4 (ptext SLIT("depends on the instantiation of") <+> - quotes (pprWithCommas ppr (varSetElems (tyVarsOfInsts tidy_dicts))))] - - fix1 = sep [ptext SLIT("Add") <+> pprInsts tidy_dicts, - ptext SLIT("to the") <+> what_doc] - - fix2 | null instance_dicts - = empty - | otherwise - = ptext SLIT("Or add an instance declaration for") <+> pprInsts instance_dicts - - instance_dicts = [d | d <- tidy_dicts, isClassDict d, not (isTyVarDict d)] - -- Insts for which it is worth suggesting an adding an instance declaration - -- Exclude implicit parameters, and tyvar dicts - - -- Checks for the ambiguous case when we have overlapping instances - ambig_overlap = any ambig_overlap1 dicts - ambig_overlap1 dict - | isClassDict dict - = case lookupInstEnv dflags inst_env clas tys of - NoMatch ambig -> ambig - other -> False - | otherwise = False - where - (clas,tys) = getDictClassTys dict - in - addErrTcM (tidy_env2, doc) - -- Used for the ...Thetas variants; all top level noInstErr pred = ptext SLIT("No instance for") <+> quotes (ppr pred)