X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=4976f41b8f8e6fca45992edde48db1a46d17c1a2;hb=4161ba13916463f8e67259498eacf22744160e1f;hp=9eb4db8dc8d6fadd587d3a46e7af0fd3acd9fa8c;hpb=2558ec224e78bc95bcdde8f65c9ee25cdcb509d9;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 9eb4db8..4976f41 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -123,7 +123,6 @@ module TcSimplify ( #include "HsVersions.h" -import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults ) import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList ) import TcHsSyn ( TcExpr, TcId, TcMonoBinds, TcDictBinds @@ -131,41 +130,43 @@ import TcHsSyn ( TcExpr, TcId, import TcMonad import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), - tyVarsOfInst, tyVarsOfInsts, - isDict, isClassDict, isMethod, isStdClassTyVarDict, - isMethodFor, notFunDep, + tyVarsOfInst, + isDict, isClassDict, isMethod, notFunDep, + isStdClassTyVarDict, isMethodFor, instToId, instBindingRequired, instCanBeGeneralised, - newDictFromOld, - getDictClassTys, getIPs, + newDictFromOld, newFunDepFromDict, + getDictClassTys, getIPs, isTyVarDict, getDictPred_maybe, getMethodTheta_maybe, instLoc, pprInst, zonkInst, tidyInst, tidyInsts, Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE, unitLIE, consLIE, plusLIE, - lieToList, listToLIE + lieToList ) -import TcEnv ( tcGetGlobalTyVars ) -import TcType ( TcType, TcTyVarSet, typeToTcType ) +import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv ) +import InstEnv ( lookupInstEnv, InstLookupResult(..) ) + +import TcType ( TcTyVarSet ) import TcUnify ( unifyTauTy ) import Id ( idType ) -import Class ( Class, classBigSig, classInstEnv ) +import Class ( Class, classBigSig ) import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) -import Type ( Type, ThetaType, TauType, ClassContext, +import Type ( Type, ClassContext, mkTyVarTy, getTyVar, isTyVarTy, splitSigmaTy, tyVarsOfTypes ) -import InstEnv ( InstEnv ) import Subst ( mkTopTyVarSubst, substClasses ) import PprType ( pprConstraint ) import TysWiredIn ( unitTy ) import VarSet import FiniteMap -import BasicTypes ( TopLevelFlag(..) ) -import CmdLineOpts ( opt_GlasgowExts ) import Outputable -import Util +import ListSetOps ( equivClasses ) +import Util ( zipEqual, mapAccumL ) import List ( partition ) +import Maybe ( fromJust ) import Maybes ( maybeToBool ) +import CmdLineOpts \end{code} @@ -188,7 +189,7 @@ tcSimplify -> TcTyVarSet -- ``Local'' type variables -- ASSERT: this tyvar set is already zonked -> LIE -- Wanted - -> TcM s (LIE, -- Free + -> TcM (LIE, -- Free TcDictBinds, -- Bindings LIE) -- Remaining wanteds; no dups @@ -231,17 +232,7 @@ tcSimplify str local_tvs wanted_lie -- Finished returnTc (mkLIE frees, binds, mkLIE irreds') where - -- the idea behind filtering out the dependencies here is that - -- they've already served their purpose, and can be reconstructed - -- at a later point from the retained class predicates. - -- however, there *is* the possibility that a dependency - -- out-lives the predicate from which it arose. - -- I don't have any examples of this, but if they show up, - -- we'd want to consider the possibility of saving the - -- dependencies as hidden constraints (i.e. they'd only - -- show up in interface files) -- or maybe they'd be useful - -- as first class predicates... - wanteds = filter notFunDep (lieToList wanted_lie) + wanteds = lieToList wanted_lie try_me inst -- Does not constrain a local tyvar @@ -270,7 +261,7 @@ tcSimplifyAndCheck -- ASSERT: this tyvar set is already zonked -> LIE -- Given; constrain only local tyvars -> LIE -- Wanted - -> TcM s (LIE, -- Free + -> TcM (LIE, -- Free TcDictBinds) -- Bindings tcSimplifyAndCheck str local_tvs given_lie wanted_lie @@ -291,9 +282,7 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie returnTc (mkLIE frees, binds) where givens = lieToList given_lie - -- see comment on wanteds in tcSimplify - -- JRL nope - it's too early to throw away fundeps here... - wanteds = {- filter notFunDep -} (lieToList wanted_lie) + wanteds = lieToList wanted_lie given_dicts = filter isClassDict givens try_me inst @@ -333,15 +322,12 @@ But that means that we must simplify the Method for f to (f Int dNumInt)! So tcSimplifyToDicts squeezes out all Methods. \begin{code} -tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds) +tcSimplifyToDicts :: LIE -> TcM (LIE, TcDictBinds) tcSimplifyToDicts wanted_lie = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) -> ASSERT( null frees ) returnTc (mkLIE irreds, binds) where - -- see comment on wanteds in tcSimplify - -- ZZ waitaminute - doesn't appear that any funDeps should even be here... - -- wanteds = filter notFunDep (lieToList wanted_lie) wanteds = lieToList wanted_lie -- Reduce methods and lits only; stop as soon as we get a dictionary @@ -512,7 +498,7 @@ The main entry point for context reduction is @reduceContext@: reduceContext :: SDoc -> (Inst -> WhatToDo) -> [Inst] -- Given -> [Inst] -- Wanted - -> TcM s (TcDictBinds, + -> TcM (TcDictBinds, [Inst], -- Free [Inst]) -- Irreducible @@ -520,6 +506,11 @@ reduceContext str try_me givens wanteds = -- Zonking first mapNF_Tc zonkInst givens `thenNF_Tc` \ givens -> mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds -> + -- JRL - process fundeps last. We eliminate fundeps by seeing + -- what available classes generate them, so we need to process the + -- classes first. (would it be useful to make LIEs ordered in the first place?) + let (wantedOther, wantedFds) = partition notFunDep wanteds + wanteds' = wantedOther ++ wantedFds in {- pprTrace "reduceContext" (vcat [ @@ -531,10 +522,10 @@ reduceContext str try_me givens wanteds ]) $ -} -- Build the Avail mapping from "givens" - foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails -> + foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails -> -- Do the real work - reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) -> + reduceList (0,[]) try_me wanteds' (avails, [], []) `thenNF_Tc` \ (avails, frees, irreds) -> -- Extract the bindings from avails let @@ -566,7 +557,7 @@ reduceContext str try_me givens wanteds text "----------------------" ]) $ -} - returnTc (binds, frees, irreds) + returnNF_Tc (binds, frees, irreds) \end{code} The main context-reduction function is @reduce@. Here's its game plan. @@ -577,7 +568,7 @@ reduceList :: (Int,[Inst]) -- Stack (for err msgs) -> (Inst -> WhatToDo) -> [Inst] -> RedState s - -> TcM s (RedState s) + -> TcM (RedState s) \end{code} @reduce@ is passed @@ -718,7 +709,7 @@ activate avails wanted addWanted avails wanted rhs_expr = ASSERT( not (wanted `elemFM` avails) ) - returnNF_Tc (addToFM avails wanted avail) + addFunDeps (addToFM avails wanted avail) wanted -- NB: we don't add the thing's superclasses too! -- Why not? Because addWanted is used when we've successfully used an -- instance decl to reduce something; e.g. @@ -763,7 +754,7 @@ addFree avails free | isDict free = addToFM avails free (Avail (instToId free) NoRhs []) | otherwise = avails -addGiven :: Avails s -> Inst -> NF_TcM s (Avails s) +addGiven :: Avails s -> Inst -> NF_TcM (Avails s) addGiven avails given = -- ASSERT( not (given `elemFM` avails) ) -- This assertion isn't necessarily true. It's permitted @@ -779,7 +770,7 @@ addGiven avails given addAvail avails wanted avail = addSuperClasses (addToFM avails wanted avail) wanted -addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s) +addSuperClasses :: Avails s -> Inst -> NF_TcM (Avails s) -- Add all the superclasses of the Inst to Avails -- Invariant: the Inst is already in Avails. @@ -788,10 +779,10 @@ addSuperClasses avails dict = returnNF_Tc avails | otherwise -- It is a dictionary - = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) + = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' -> + addFunDeps avails' dict where (clas, tys) = getDictClassTys dict - (tyvars, sc_theta, sc_sels, _) = classBigSig clas sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta @@ -824,6 +815,16 @@ addSuperClasses avails dict avail = Avail (instToId super_dict) (PassiveScSel sc_sel_rhs [dict]) [] + +addFunDeps :: Avails s -> Inst -> NF_TcM (Avails s) + -- Add in the functional dependencies generated by the inst +addFunDeps avails inst + = newFunDepFromDict inst `thenNF_Tc` \ fdInst_maybe -> + case fdInst_maybe of + Nothing -> returnNF_Tc avails + Just fdInst -> + let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in + addAvail avails fdInst fdAvail \end{code} %************************************************************************ @@ -843,22 +844,22 @@ a,b,c are type variables. This is required for the context of instance declarations. \begin{code} -tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv - -> ClassContext -- Wanted - -> TcM s ClassContext -- Needed +tcSimplifyThetas :: ClassContext -- Wanted + -> TcM ClassContext -- Needed -tcSimplifyThetas inst_mapper wanteds - = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds -> +tcSimplifyThetas wanteds + = doptsTc Opt_GlasgowExts `thenNF_Tc` \ glaExts -> + reduceSimple [] wanteds `thenNF_Tc` \ irreds -> let -- For multi-param Haskell, check that the returned dictionaries -- don't have any of the form (C Int Bool) for which -- we expect an instance here -- For Haskell 98, check that all the constraints are of the form C a, -- where a is a type variable - bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds, - isEmptyVarSet (tyVarsOfTypes tys)] - | otherwise = [ct | ct@(clas,tys) <- irreds, - not (all isTyVarTy tys)] + bad_guys | glaExts = [ct | ct@(clas,tys) <- irreds, + isEmptyVarSet (tyVarsOfTypes tys)] + | otherwise = [ct | ct@(clas,tys) <- irreds, + not (all isTyVarTy tys)] in if null bad_guys then returnTc irreds @@ -874,10 +875,10 @@ whether it worked or not. \begin{code} tcSimplifyCheckThetas :: ClassContext -- Given -> ClassContext -- Wanted - -> TcM s () + -> TcM () tcSimplifyCheckThetas givens wanteds - = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds -> + = reduceSimple givens wanteds `thenNF_Tc` \ irreds -> if null irreds then returnTc () else @@ -891,40 +892,38 @@ type AvailsSimple = FiniteMap (Class,[Type]) Bool -- True => irreducible -- False => given, or can be derived from a given or from an irreducible -reduceSimple :: (Class -> InstEnv) - -> ClassContext -- Given +reduceSimple :: ClassContext -- Given -> ClassContext -- Wanted - -> NF_TcM s ClassContext -- Irreducible + -> NF_TcM ClassContext -- Irreducible -reduceSimple inst_mapper givens wanteds - = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' -> +reduceSimple givens wanteds + = reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' -> returnNF_Tc [ct | (ct,True) <- fmToList givens_fm'] where givens_fm = foldl addNonIrred emptyFM givens reduce_simple :: (Int,ClassContext) -- Stack - -> (Class -> InstEnv) -> AvailsSimple -> ClassContext - -> NF_TcM s AvailsSimple + -> NF_TcM AvailsSimple -reduce_simple (n,stack) inst_mapper avails wanteds +reduce_simple (n,stack) avails wanteds = go avails wanteds where go avails [] = returnNF_Tc avails - go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' -> + go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w `thenNF_Tc` \ avails' -> go avails' ws -reduce_simple_help stack inst_mapper givens wanted@(clas,tys) +reduce_simple_help stack givens wanted@(clas,tys) | wanted `elemFM` givens = returnNF_Tc givens | otherwise - = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta -> + = lookupSimpleInst clas tys `thenNF_Tc` \ maybe_theta -> case maybe_theta of Nothing -> returnNF_Tc (addIrred givens wanted) - Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta + Just theta -> reduce_simple stack (addNonIrred givens wanted) theta addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple addIrred givens ct@(clas,tys) @@ -979,7 +978,7 @@ For each method @Inst@ in the @init_lie@ that mentions one of the @LIE@), as well as the @HsBinds@ generated. \begin{code} -bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds) +bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM (LIE, TcMonoBinds) bindInstsOfLocalFuns init_lie local_ids | null overloaded_ids || null lie_for_here @@ -1050,7 +1049,7 @@ variable, and using @disambigOne@ to do the real business. all the constant and ambiguous Insts. \begin{code} -tcSimplifyTop :: LIE -> TcM s TcDictBinds +tcSimplifyTop :: LIE -> TcM TcDictBinds tcSimplifyTop wanted_lie = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) -> ASSERT( null frees ) @@ -1074,7 +1073,6 @@ tcSimplifyTop wanted_lie -- Collect together all the bad guys bad_guys = non_stds ++ concat std_bads in - -- Disambiguate the ones that look feasible mapTc disambigGroup std_oks `thenTc` \ binds_ambig -> @@ -1083,8 +1081,7 @@ tcSimplifyTop wanted_lie returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig) where - -- see comment on wanteds in tcSimplify - wanteds = filter notFunDep (lieToList wanted_lie) + wanteds = lieToList wanted_lie try_me inst = ReduceMe AddToIrreds d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 @@ -1113,7 +1110,7 @@ Since we're not using the result of @foo@, the result if (presumably) \begin{code} disambigGroup :: [Inst] -- All standard classes of form (C a) - -> TcM s TcDictBinds + -> TcM TcDictBinds disambigGroup dicts | any isNumericClass classes -- Guaranteed all standard classes @@ -1148,10 +1145,7 @@ disambigGroup dicts try_default default_tys `thenTc` \ chosen_default_ty -> -- Bind the type variable and reduce the context, for real this time - let - chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome! - in - unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_` + unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenTc_` reduceContext (text "disambig" <+> ppr dicts) try_me [] dicts `thenTc` \ (binds, frees, ambigs) -> ASSERT( null frees && null ambigs ) @@ -1231,28 +1225,27 @@ addAmbigErr ambig_tv_fn dict (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict warnDefault dicts default_ty - | not opt_WarnTypeDefaults - = returnNF_Tc () + = doptsTc Opt_WarnTypeDefaults `thenTc` \ warn_flag -> + if warn_flag + then mapNF_Tc warn groups `thenNF_Tc_` returnNF_Tc () + else returnNF_Tc () - | otherwise - = warnTc True msg where - msg | length dicts > 1 - = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) - $$ pprInstsInFull tidy_dicts - | otherwise - = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+> - ptext SLIT("to type") <+> quotes (ppr default_ty) - + -- Tidy them first (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts -addRuleLhsErr dict - = addInstErrTcM (instLoc dict) - (tidy_env, - vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict), - nest 4 (ptext SLIT("LHS of a rule must have no overloading"))]) - where - (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict + -- Group the dictionaries by source location + groups = equivClasses cmp tidy_dicts + i1 `cmp` i2 = get_loc i1 `compare` get_loc i2 + get_loc i = case instLoc i of { (_,loc,_) -> loc } + + warn [dict] = tcAddSrcLoc (get_loc dict) $ + warnTc True (ptext SLIT("Defaulting") <+> quotes (pprInst dict) <+> + ptext SLIT("to type") <+> quotes (ppr default_ty)) + + warn dicts = tcAddSrcLoc (get_loc (head dicts)) $ + warnTc True (vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty), + pprInstsInFull dicts]) addTopIPErr dict = addInstErrTcM (instLoc dict) @@ -1269,22 +1262,52 @@ addTopInstanceErr dict where (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict +-- 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. addNoInstanceErr str givens dict - = addInstErrTcM (instLoc dict) - (tidy_env, - sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict), - nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens] - $$ - ptext SLIT("Probable cause:") <+> - vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict), - ptext SLIT("in") <+> str], - if isClassDict dict && all_tyvars then empty else - ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)] - ) - where - all_tyvars = all isTyVarTy tys - (_, tys) = getDictClassTys dict - (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens) + = tcGetInstEnv `thenNF_Tc` \ inst_env -> + let + doc = vcat [sep [herald <+> quotes (pprInst tidy_dict), + 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 + + 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 (tyVarsOfInst tidy_dict))))] + + fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict), + ptext SLIT("to the") <+> str] + + fix2 | isTyVarDict dict || ambig_overlap + = empty + | otherwise + = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict) + + (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens) + + -- Checks for the ambiguous case when we have overlapping instances + ambig_overlap | isClassDict dict + = case lookupInstEnv inst_env clas tys of + NoMatch ambig -> ambig + other -> False + | otherwise = False + where + (clas,tys) = getDictClassTys dict + in + addInstErrTcM (instLoc dict) (tidy_env, doc) -- Used for the ...Thetas variants; all top level addNoInstErr (c,ts)