X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=1bf752ce79f9b29a035060e797d72ecabc4a5336;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=2aa4ef5afa4ca095404bb696d3e4b60d855d977c;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 2aa4ef5..1bf752c 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -1,149 +1,178 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcSimplify]{TcSimplify} -\begin{code} -#include "HsVersions.h" +Notes: -module TcSimplify ( - tcSimplify, tcSimplifyAndCheck, - tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2, - bindInstsOfLocalFuns - ) where +Inference (local definitions) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the inst constrains a local type variable, then + [ReduceMe] if it's a literal or method inst, reduce it -IMP_Ubiq() + [DontReduce] otherwise see whether the inst is just a constant + if succeed, use it + if not, add original to context + This check gets rid of constant dictionaries without + losing sharing. -import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, - Match, HsBinds, HsType, ArithSeqInfo, Fixity, - GRHSsAndBinds, Stmt, DoOrListComp, Fake ) -import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) ) +If the inst does not constrain a local type variable then + [Free] then throw it out as free. -import TcMonad -import Inst ( lookupInst, lookupSimpleInst, - tyVarsOfInst, isTyVarDict, isDict, - matchesInst, instToId, instBindingRequired, - instCanBeGeneralised, newDictsAtLoc, - pprInst, - Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE, - plusLIE, unitLIE, consLIE, InstOrigin(..), - OverloadedLit ) -import TcEnv ( tcGetGlobalTyVars ) -import SpecEnv ( SpecEnv ) -import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType ) -import Unify ( unifyTauTy ) - -import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, - snocBag, consBag, unionBags, isEmptyBag ) -import Class ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv), - isSuperClassOf, classSuperDictSelId, classInstEnv - ) -import Id ( GenId ) -import PrelInfo ( isNumericClass, isStandardClass, isCcallishClass ) - -import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool ) -import Outputable ( Outputable(..){-instance * []-} ) ---import PprStyle--ToDo:rm -import PprType ( GenType, GenTyVar ) -import Pretty -import SrcLoc ( noSrcLoc ) -import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy, - getTyVar_maybe ) -import TysWiredIn ( intTy, unitTy ) -import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), - elementOfTyVarSet, emptyTyVarSet, unionTyVarSets, - isEmptyTyVarSet, tyVarSetToList ) -import Unique ( Unique ) -import Util -\end{code} +Inference (top level definitions) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the inst does not constrain a local type variable, then + [FreeIfTautological] try for tautology; + if so, throw it out as free + (discarding result of tautology check) + if not, make original inst part of the context + (eliminating superclasses as usual) +If the inst constrains a local type variable, then + as for inference (local defns) -%************************************************************************ -%* * -\subsection[tcSimplify-main]{Main entry function} -%* * -%************************************************************************ -* May modify the substitution to bind ambiguous type variables. +Checking (local defns) +~~~~~~~~ +If the inst constrains a local type variable then + [ReduceMe] reduce (signal error on failure) -Specification -~~~~~~~~~~~~~ -(1) If an inst constrains only ``global'' type variables, (or none), - return it as a ``global'' inst. +If the inst does not constrain a local type variable then + [Free] throw it out as free. -OTHERWISE +Checking (top level) +~~~~~~~~~~~~~~~~~~~~ +If the inst constrains a local type variable then + as for checking (local defns) -(2) Simplify it repeatedly (checking for (1) of course) until it is a dict - constraining only a type variable. +If the inst does not constrain a local type variable then + as for checking (local defns) -(3) If it constrains a ``local'' type variable, return it as a ``local'' inst. - Otherwise it must be ambiguous, so try to resolve the ambiguity. -\begin{code} -tcSimpl :: Bool -- True <=> simplify const insts - -> TcTyVarSet s -- ``Global'' type variables - -> TcTyVarSet s -- ``Local'' type variables - -- ASSERT: both these tyvar sets are already zonked - -> LIE s -- Given; these constrain only local tyvars - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - [(TcIdOcc s,TcExpr s)], -- Bindings - LIE s) -- Remaining wanteds; no dups +Checking once per module +~~~~~~~~~~~~~~~~~~~~~~~~~ +For dicts of the form (C a), where C is a std class + and "a" is a type variable, + [DontReduce] add to context -tcSimpl squash_consts global_tvs local_tvs givens wanteds - = -- ASSSERT: global_tvs and local_tvs are already zonked - -- Make sure the insts fixed points of the substitution - zonkLIE givens `thenNF_Tc` \ givens -> - zonkLIE wanteds `thenNF_Tc` \ wanteds -> +otherwise [ReduceMe] always reduce - -- Deal with duplicates and type constructors - elimTyCons - squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs) - givens wanteds `thenTc` \ (globals, tycon_binds, locals_and_ambigs) -> +[NB: we may generate one Tree [Int] dict per module, so + sharing is not complete.] - -- Now disambiguate if necessary - let - ambigs = filterBag is_ambiguous locals_and_ambigs - in - if not (isEmptyBag ambigs) then - -- Some ambiguous dictionaries. We now disambiguate them, - -- which binds the offending type variables to suitable types in the - -- substitution, and then we retry the whole process. This - -- time there won't be any ambiguous ones. - -- There's no need to back-substitute on global and local tvs, - -- because the ambiguous type variables can't be in either. +Sort out ambiguity at the end. - -- Why do we retry the whole process? Because binding a type variable - -- to a particular type might enable a short-cut simplification which - -- elimTyCons will have missed the first time. +Principal types +~~~~~~~~~~~~~~~ +class C a where + op :: a -> a - disambiguateDicts ambigs `thenTc_` - tcSimpl squash_consts global_tvs local_tvs givens wanteds +f x = let g y = op (y::Int) in True - else - -- No ambiguous dictionaries. Just bash on with the results - -- of the elimTyCons +Here the principal type of f is (forall a. a->a) +but we'll produce the non-principal type + f :: forall a. C Int => a -> a - -- Check for non-generalisable insts - let - locals = locals_and_ambigs -- ambigs is empty - cant_generalise = filterBag (not . instCanBeGeneralised) locals - in - checkTc (isEmptyBag cant_generalise) - (genCantGenErr cant_generalise) `thenTc_` +Ambiguity +~~~~~~~~~ +Consider this: - -- Deal with superclass relationships - elimSCs givens locals `thenNF_Tc` \ (sc_binds, locals2) -> + instance C (T a) Int where ... + instance C (T a) Bool where ... - -- Finished - returnTc (globals, bagToList (sc_binds `unionBags` tycon_binds), locals2) - where - is_ambiguous (Dict _ _ ty _ _) - = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs) +and suppose we infer a context + + C (T x) y + +from some expression, where x and y are type varibles, +and x is ambiguous, and y is being quantified over. +Should we complain, or should we generate the type + + forall x y. C (T x) y => + +The idea is that at the call of the function we might +know that y is Int (say), so the "x" isn't really ambiguous. +Notice that we have to add "x" to the type variables over +which we generalise. + +Something similar can happen even if C constrains only ambiguous +variables. Suppose we infer the context + + C [x] + +where x is ambiguous. Then we could infer the type + + forall x. C [x] => + +in the hope that at the call site there was an instance +decl such as + + instance Num a => C [a] where ... + +and hence the default mechanism would resolve the "a". + + +\begin{code} +module TcSimplify ( + tcSimplify, tcSimplifyAndCheck, + tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, + bindInstsOfLocalFuns + ) where + +#include "HsVersions.h" + +import CmdLineOpts ( opt_MaxContextReductionDepth ) +import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList ) +import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr, + TcMonoBinds, TcDictBinds + ) + +import TcMonad +import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), + tyVarsOfInst, + isDict, isStdClassTyVarDict, isMethodFor, + instToId, instBindingRequired, instCanBeGeneralised, + newDictFromOld, + instLoc, getDictClassTys, + pprInst, zonkInst, tidyInst, tidyInsts, + Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE, + plusLIE, pprOrigin + ) +import TcEnv ( TcIdOcc(..), tcGetGlobalTyVars ) +import TcType ( TcType, TcTyVarSet, typeToTcType ) +import TcUnify ( unifyTauTy ) +import Id ( idType ) +import VarSet ( mkVarSet ) + +import Bag ( bagToList ) +import Class ( Class, ClassInstEnv, classBigSig, classInstEnv ) +import PrelInfo ( isNumericClass, isCreturnableClass ) + +import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar, + isTyVarTy, substFlexiTheta, splitSigmaTy, + tyVarsOfTypes + ) +import PprType ( pprConstraint ) +import TysWiredIn ( unitTy ) +import VarSet +import VarEnv ( zipVarEnv ) +import FiniteMap +import BasicTypes ( TopLevelFlag(..) ) +import CmdLineOpts ( opt_GlasgowExts ) +import Outputable +import Util +import List ( partition ) \end{code} + +%************************************************************************ +%* * +\subsection[tcSimplify-main]{Main entry function} +%* * +%************************************************************************ + The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with the ``don't-squash-consts'' flag set depending on top-level ness. For top level defns we *do* squash constants, so that they stay local to a @@ -153,15 +182,66 @@ float them out if poss, after inlinings are sorted out. \begin{code} tcSimplify - :: TcTyVarSet s -- ``Local'' type variables + :: SDoc + -> TopLevelFlag + -> TcTyVarSet s -- ``Local'' type variables + -- ASSERT: this tyvar set is already zonked -> LIE s -- Wanted -> TcM s (LIE s, -- Free - [(TcIdOcc s,TcExpr s)], -- Bindings + TcDictBinds s, -- Bindings LIE s) -- Remaining wanteds; no dups -tcSimplify local_tvs wanteds - = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> - tcSimpl False global_tvs local_tvs emptyBag wanteds +tcSimplify str top_lvl local_tvs wanted_lie + | isEmptyVarSet local_tvs + = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE) + + | otherwise + = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) -> + + -- Check for non-generalisable insts + let + cant_generalise = filter (not . instCanBeGeneralised) irreds + in + checkTc (null cant_generalise) + (genCantGenErr cant_generalise) `thenTc_` + + -- Check for ambiguous insts. + -- You might think these can't happen (I did) because an ambiguous + -- inst like (Eq a) will get tossed out with "frees", and eventually + -- dealt with by tcSimplifyTop. + -- But we can get stuck with + -- C a b + -- where "a" is one of the local_tvs, but "b" is unconstrained. + -- Then we must yell about the ambiguous b + -- But we must only do so if "b" really is unconstrained; so + -- we must grab the global tyvars to answer that question + tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> + let + avail_tvs = local_tvs `unionVarSet` global_tvs + (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds + ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs + in + addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_` + + + -- Finished + returnTc (mkLIE frees, binds, mkLIE irreds') + where + wanteds = bagToList wanted_lie + + try_me inst + -- Does not constrain a local tyvar + | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) + = -- if is_top_level then + -- FreeIfTautological -- Special case for inference on + -- -- top-level defns + -- else + Free + + -- We're infering (not checking) the type, and + -- the inst constrains a local type variable + | isDict inst = DontReduce -- Dicts + | otherwise = ReduceMe AddToIrreds -- Lits and Methods \end{code} @tcSimplifyAndCheck@ is similar to the above, except that it checks @@ -170,298 +250,437 @@ some of constant insts, which have to be resolved finally at the end. \begin{code} tcSimplifyAndCheck - :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint - -> LIE s -- Given + :: SDoc + -> TcTyVarSet s -- ``Local'' type variables + -- ASSERT: this tyvar set is already zonked + -> LIE s -- Given; constrain only local tyvars -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - [(TcIdOcc s,TcExpr s)]) -- Bindings - -tcSimplifyAndCheck local_tvs givens wanteds - = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> - tcSimpl False global_tvs local_tvs - givens wanteds `thenTc` \ (free_insts, binds, wanteds') -> - checkTc (isEmptyBag wanteds') - (reduceErr wanteds') `thenTc_` - returnTc (free_insts, binds) -\end{code} + -> TcM s (LIE s, -- Free + TcDictBinds s) -- Bindings -@tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function -is not overloaded. - -\begin{code} -tcSimplifyRank2 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint - -> LIE s -- Given - -> TcM s (LIE s, -- Free - [(TcIdOcc s,TcExpr s)]) -- Bindings +tcSimplifyAndCheck str local_tvs given_lie wanted_lie + | isEmptyVarSet local_tvs + -- This can happen quite legitimately; for example in + -- instance Num Int where ... + = returnTc (wanted_lie, EmptyMonoBinds) + | otherwise + = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) -> -tcSimplifyRank2 local_tvs givens - = zonkLIE givens `thenNF_Tc` \ givens' -> - elimTyCons True - (\tv -> not (tv `elementOfTyVarSet` local_tvs)) - -- This predicate claims that all - -- any non-local tyvars are global, - -- thereby postponing dealing with - -- ambiguity until the enclosing Gen - emptyLIE givens' `thenTc` \ (free, dict_binds, wanteds) -> + -- Complain about any irreducible ones + mapNF_Tc complain irreds `thenNF_Tc_` - checkTc (isEmptyBag wanteds) (reduceErr wanteds) `thenTc_` + -- Done + returnTc (mkLIE frees, binds) + where + givens = bagToList given_lie + wanteds = bagToList wanted_lie - returnTc (free, bagToList dict_binds) -\end{code} + try_me inst + -- Does not constrain a local tyvar + | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) + = Free -@tcSimplifyTop@ deals with constant @Insts@, using the standard simplification -mechansim with the extra flag to say ``beat out constant insts''. + -- When checking against a given signature we always reduce + -- until we find a match against something given, or can't reduce + | otherwise + = ReduceMe AddToIrreds -\begin{code} -tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)] -tcSimplifyTop dicts - = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) -> - returnTc binds + complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens -> + addNoInstanceErr str givens dict \end{code} + %************************************************************************ %* * -\subsection[elimTyCons]{@elimTyCons@} +\subsection{Data types for the reduction mechanism} %* * %************************************************************************ +The main control over context reduction is here + \begin{code} -elimTyCons :: Bool -- True <=> Simplify const insts - -> (TcTyVar s -> Bool) -- Free tyvar predicate - -> LIE s -- Given - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - Bag (TcIdOcc s, TcExpr s), -- Bindings - LIE s -- Remaining wanteds; no dups; - -- dicts only (no Methods) - ) -\end{code} +data WhatToDo + = ReduceMe -- Try to reduce this + NoInstanceAction -- What to do if there's no such instance -The bindings returned may mention any or all of ``givens'', so the -order in which the generated binds are put together is {\em tricky}. -Case~4 of @try@ is the general case to see. + | DontReduce -- Return as irreducible -When we do @eTC givens (wanted:wanteds)@ [some details omitted], we... + | Free -- Return as free - (1) first look up @wanted@; this gives us one binding to heave in: - wanted = rhs + | FreeIfTautological -- Return as free iff it's tautological; + -- if not, return as irreducible - (2) step (1) also gave us some @simpler_wanteds@; we simplify - these and get some (simpler-wanted-)bindings {\em that must be - in scope} for the @wanted=rhs@ binding above! +data NoInstanceAction + = Stop -- Fail; no error message + -- (Only used when tautology checking.) - (3) we simplify the remaining @wanteds@ (recursive call), giving - us yet more bindings. + | AddToIrreds -- Just add the inst to the irreductible ones; don't + -- produce an error message of any kind. + -- It might be quite legitimate such as (Eq a)! +\end{code} -The final arrangement of the {\em non-recursive} bindings is - let in - let wanted = rhs in - let ... \begin{code} -elimTyCons squash_consts is_free_tv givens wanteds - = eTC givens (bagToList wanteds) `thenTc` \ (_, free, binds, irreds) -> - returnTc (free,binds,irreds) +type RedState s + = (Avails s, -- What's available + [Inst s], -- Insts for which try_me returned Free + [Inst s] -- Insts for which try_me returned DontReduce + ) + +type Avails s = FiniteMap (Inst s) (Avail s) + +data Avail s + = Avail + (TcIdOcc s) -- The "main Id"; that is, the Id for the Inst that + -- caused this avail to be put into the finite map in the first place + -- It is this Id that is bound to the RHS. + + (RHS s) -- The RHS: an expression whose value is that Inst. + -- The main Id should be bound to this RHS + + [TcIdOcc s] -- Extra Ids that must all be bound to the main Id. + -- At the end we generate a list of bindings + -- { i1 = main_id; i2 = main_id; i3 = main_id; ... } + +data RHS s + = NoRhs -- Used for irreducible dictionaries, + -- which are going to be lambda bound, or for those that are + -- suppplied as "given" when checking againgst a signature. + -- + -- NoRhs is also used for Insts like (CCallable f) + -- where no witness is required. + + | Rhs -- Used when there is a RHS + (TcExpr s) + Bool -- True => the RHS simply selects a superclass dictionary + -- from a subclass dictionary. + -- False => not so. + -- This is useful info, because superclass selection + -- is cheaper than building the dictionary using its dfun, + -- and we can sometimes replace the latter with the former + + | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have + -- an (Ord t) dictionary; then we put an (Eq t) entry in + -- the finite map, with an PassiveScSel. Then if the + -- the (Eq t) binding is ever *needed* we make it an Rhs + (TcExpr s) + [Inst s] -- List of Insts that are free in the RHS. + -- If the main Id is subsequently needed, we toss this list into + -- the needed-inst pool so that we make sure their bindings + -- will actually be produced. + -- + -- Invariant: these Insts are already in the finite mapping + + +pprAvails avails = vcat (map pp (eltsFM avails)) where --- eTC :: LIE s -> [Inst s] --- -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s) - - eTC givens [] = returnTc (givens, emptyBag, emptyBag, emptyBag) - - eTC givens (wanted:wanteds) - -- Case 0: same as an existing inst - | maybeToBool maybe_equiv - = eTC givens wanteds `thenTc` \ (givens1, frees, binds, irreds) -> - let - -- Create a new binding iff it's needed - this = expectJust "eTC" maybe_equiv - new_binds | instBindingRequired wanted = (instToId wanted, HsVar (instToId this)) - `consBag` binds - | otherwise = binds - in - returnTc (givens1, frees, new_binds, irreds) - - -- Case 1: constrains no type variables at all - -- In this case we have a quick go to see if it has an - -- instance which requires no inputs (ie a constant); if so we use - -- it; if not, we give up on the instance and just heave it out the - -- top in the free result - | isEmptyTyVarSet tvs_of_wanted - = simplify_it squash_consts {- If squash_consts is false, - simplify only if trival -} - givens wanted wanteds - - -- Case 2: constrains free vars only, so fling it out the top in free_ids - | all is_free_tv (tyVarSetToList tvs_of_wanted) - = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) -> - returnTc (givens1, wanted `consBag` frees, binds, irreds) - - -- Case 3: is a dict constraining only a tyvar, - -- so return it as part of the "wanteds" result - | isTyVarDict wanted - = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) -> - returnTc (givens1, frees, binds, wanted `consBag` irreds) - - -- Case 4: is not a simple dict, so look up in instance environment - | otherwise - = simplify_it True {- Simplify even if not trivial -} - givens wanted wanteds - where - tvs_of_wanted = tyVarsOfInst wanted - - -- Look for something in "givens" that matches "wanted" - Just the_equiv = maybe_equiv - maybe_equiv = foldBag seqMaybe try Nothing givens - try given | wanted `matchesInst` given = Just given - | otherwise = Nothing - - - simplify_it simplify_always givens wanted wanteds - -- Recover immediately on no-such-instance errors - = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, emptyBag, emptyLIE)) - (simplify_one simplify_always givens wanted) - `thenTc` \ (givens1, frees1, binds1, irreds1) -> - eTC givens1 wanteds `thenTc` \ (givens2, frees2, binds2, irreds2) -> - returnTc (givens2, frees1 `plusLIE` frees2, - binds1 `unionBags` binds2, - irreds1 `plusLIE` irreds2) - - - simplify_one simplify_always givens wanted - | not (instBindingRequired wanted) - = -- No binding required for this chap, so squash right away - lookupInst wanted `thenTc` \ (simpler_wanteds, _) -> - eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) -> - returnTc (wanted `consBag` givens1, frees1, binds1, irreds1) - - | otherwise - = -- An binding is required for this inst - lookupInst wanted `thenTc` \ (simpler_wanteds, bind@(_,rhs)) -> - - if (not_var rhs && not simplify_always) then - -- Ho ho! It isn't trivial to simplify "wanted", - -- because the rhs isn't a simple variable. Unless the flag - -- simplify_always is set, just give up now and - -- just fling it out the top. - returnTc (wanted `consLIE` givens, unitLIE wanted, emptyBag, emptyLIE) - else - -- Aha! Either it's easy, or simplify_always is True - -- so we must do it right here. - eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) -> - returnTc (wanted `consLIE` givens1, frees1, - binds1 `snocBag` bind, - irreds1) - - not_var :: TcExpr s -> Bool - not_var (HsVar _) = False - not_var other = True + pp (Avail main_id rhs ids) + = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs + +pprRhs NoRhs = text "" +pprRhs (Rhs rhs b) = ppr rhs +pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs \end{code} %************************************************************************ %* * -\subsection[elimSCs]{@elimSCs@} +\subsection[reduce]{@reduce@} %* * %************************************************************************ -\begin{code} -elimSCs :: LIE s -- Given; no dups - -> LIE s -- Wanted; no dups; all dictionaries, all - -- constraining just a type variable - -> NF_TcM s (Bag (TcIdOcc s,TcExpr s), -- Bindings - LIE s) -- Minimal wanted set - -elimSCs givens wanteds - = -- Sort the wanteds so that subclasses occur before superclasses - elimSCs_help - (filterBag isDict givens) -- Filter out non-dictionaries - (sortSC wanteds) - -elimSCs_help :: LIE s -- Given; no dups - -> [Inst s] -- Wanted; no dups; - -> NF_TcM s (Bag (TcIdOcc s, TcExpr s), -- Bindings - LIE s) -- Minimal wanted set - -elimSCs_help given [] = returnNF_Tc (emptyBag, emptyLIE) - -elimSCs_help givens (wanted:wanteds) - = trySC givens wanted `thenNF_Tc` \ (givens1, binds1, irreds1) -> - elimSCs_help givens1 wanteds `thenNF_Tc` \ (binds2, irreds2) -> - returnNF_Tc (binds1 `unionBags` binds2, irreds1 `plusLIE` irreds2) - - -trySC :: LIE s -- Givens - -> Inst s -- Wanted - -> NF_TcM s (LIE s, -- New givens, - Bag (TcIdOcc s,TcExpr s), -- Bindings - LIE s) -- Irreducible wanted set - -trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc) - | not (maybeToBool maybe_best_subclass_chain) - = -- No superclass relationship - returnNF_Tc ((wanted `consLIE` givens), emptyBag, unitLIE wanted) +The main entry point for context reduction is @reduceContext@: - | otherwise - = -- There's a subclass relationship with a "given" - -- Build intermediate dictionaries +\begin{code} +reduceContext :: SDoc -> (Inst s -> WhatToDo) + -> [Inst s] -- Given + -> [Inst s] -- Wanted + -> TcM s (TcDictBinds s, + [Inst s], -- Free + [Inst s]) -- Irreducible + +reduceContext str try_me givens wanteds + = -- Zonking first + mapNF_Tc zonkInst givens `thenNF_Tc` \ givens -> + mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds -> + +{- + pprTrace "reduceContext" (vcat [ + text "----------------------", + str, + text "given" <+> ppr givens, + text "wanted" <+> ppr wanteds, + text "----------------------" + ]) $ +-} + -- Build the Avail mapping from "givens" + foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails -> + + -- Do the real work + reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) -> + + -- Extract the bindings from avails let - theta = [ (clas, wanted_ty) | clas <- reverse classes ] - -- The reverse is because the list comes back in the "wrong" order I think + binds = foldFM add_bind EmptyMonoBinds avails + + add_bind _ (Avail main_id rhs ids) binds + = foldr add_synonym (add_rhs_bind rhs binds) ids + where + add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs + add_rhs_bind other binds = binds + + -- Add the trivial {x = y} bindings + -- The main Id can end up in the list when it's first added passively + -- and then activated, so we have to filter it out. A bit of a hack. + add_synonym id binds + | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id) + | otherwise = binds in - newDictsAtLoc wanted_orig loc theta `thenNF_Tc` \ (intermediates, _) -> +{- + pprTrace ("reduceContext end") (vcat [ + text "----------------------", + str, + text "given" <+> ppr givens, + text "wanted" <+> ppr wanteds, + text "----", + text "avails" <+> pprAvails avails, + text "irreds" <+> ppr irreds, + text "----------------------" + ]) $ +-} + returnTc (binds, frees, irreds) +\end{code} - -- Create bindings for the wanted dictionary and the intermediates. - -- Later binds may depend on earlier ones, so each new binding is pushed - -- on the front of the accumulating parameter list of bindings - let - mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _) - = ((dict_sub, dict_sub_class), - (instToId dict, DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class - clas))) - [ty]) - [instToId dict_sub])) - (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates) - in - returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates, - listToBag new_binds, - emptyLIE) +The main context-reduction function is @reduce@. Here's its game plan. + +\begin{code} +reduceList :: (Int,[Inst s]) + -> (Inst s -> WhatToDo) + -> [Inst s] + -> RedState s + -> TcM s (RedState s) +\end{code} + +@reduce@ is passed + try_me: given an inst, this function returns + Reduce reduce this + DontReduce return this in "irreds" + Free return this in "frees" + + wanteds: The list of insts to reduce + state: An accumulating parameter of type RedState + that contains the state of the algorithm + + It returns a RedState. + + +\begin{code} +reduceList (n,stack) try_me wanteds state + | n > opt_MaxContextReductionDepth + = failWithTc (reduceDepthErr n stack) + | otherwise + = +#ifdef DEBUG + (if n > 4 then + pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack) + else (\x->x)) +#endif + go wanteds state where - maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens - Just (given, classes, _) = maybe_best_subclass_chain + go [] state = returnTc state + go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' -> + go ws state' + + -- Base case: we're done! +reduce stack try_me wanted state@(avails, frees, irreds) + + -- It's the same as an existing inst, or a superclass thereof + | wanted `elemFM` avails + = returnTc (activate avails wanted, frees, irreds) + + -- It should be reduced + | case try_me_result of { ReduceMe _ -> True; _ -> False } + = lookupInst wanted `thenNF_Tc` \ lookup_result -> + + case lookup_result of + GenInst wanteds' rhs -> use_instance wanteds' rhs + SimpleInst rhs -> use_instance [] rhs + + NoInstance -> -- No such instance! + -- Decide what to do based on the no_instance_action requested + case no_instance_action of + Stop -> failTc -- Fail + AddToIrreds -> add_to_irreds -- Add the offending insts to the irreds + + -- It's free and this isn't a top-level binding, so just chuck it upstairs + | case try_me_result of { Free -> True; _ -> False } + = -- First, see if the inst can be reduced to a constant in one step + lookupInst wanted `thenNF_Tc` \ lookup_result -> + case lookup_result of + SimpleInst rhs -> use_instance [] rhs + other -> add_to_frees + + -- It's free and this is a top level binding, so + -- check whether it's a tautology or not + | case try_me_result of { FreeIfTautological -> True; _ -> False } + = -- Try for tautology + tryTc + -- If tautology trial fails, add to irreds + (addGiven avails wanted `thenNF_Tc` \ avails' -> + returnTc (avails', frees, wanted:irreds)) + + -- If tautology succeeds, just add to frees + (reduce stack try_me_taut wanted (avails, [], []) `thenTc_` + returnTc (avails, wanted:frees, irreds)) + + + -- It's irreducible (or at least should not be reduced) + | otherwise + = ASSERT( case try_me_result of { DontReduce -> True; other -> False } ) + -- See if the inst can be reduced to a constant in one step + lookupInst wanted `thenNF_Tc` \ lookup_result -> + case lookup_result of + SimpleInst rhs -> use_instance [] rhs + other -> add_to_irreds - choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2 = c1 - | otherwise = c2 - choose_best Nothing c2 = c2 - choose_best c1 Nothing = c1 + where + -- The three main actions + add_to_frees = let + avails' = addFree avails wanted + -- Add the thing to the avails set so any identical Insts + -- will be commoned up with it right here + in + returnTc (avails', wanted:frees, irreds) + + add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' -> + returnTc (avails', frees, wanted:irreds) + + use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' -> + reduceList stack try_me wanteds' (avails', frees, irreds) + + try_me_result = try_me wanted + ReduceMe no_instance_action = try_me_result + + -- The try-me to use when trying to identify tautologies + -- It blunders on reducing as much as possible + try_me_taut inst = ReduceMe Stop -- No error recovery +\end{code} - find_subclass_chain given@(Dict _ given_class given_ty _ _) - | wanted_ty `eqSimpleTy` given_ty - = case (wanted_class `isSuperClassOf` given_class) of - Just classes -> Just (given, - classes, - length classes) +\begin{code} +activate :: Avails s -> Inst s -> Avails s + -- Activate the binding for Inst, ensuring that a binding for the + -- wanted Inst will be generated. + -- (Activate its parent if necessary, recursively). + -- Precondition: the Inst is in Avails already - Nothing -> Nothing +activate avails wanted + | not (instBindingRequired wanted) + = avails - | otherwise = Nothing + | otherwise + = case lookupFM avails wanted of + Just (Avail main_id (PassiveScSel rhs insts) ids) -> + foldl activate avails' insts -- Activate anything it needs + where + avails' = addToFM avails wanted avail' + avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it -sortSC :: LIE s -- Expected to be all dicts (no MethodIds), all of - -- which constrain type variables - -> [Inst s] -- Sorted with subclasses before superclasses + Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list + addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids)) -sortSC dicts = sortLt lt (bagToList dicts) + Nothing -> panic "activate" where - (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _) - = maybeToBool (c2 `isSuperClassOf` c1) - -- The ice is a bit thin here because this "lt" isn't a total order - -- But it *is* transitive, so it works ok -\end{code} + wanted_id = instToId wanted + +addWanted avails wanted rhs_expr + = ASSERT( not (wanted `elemFM` avails) ) + returnNF_Tc (addToFM avails wanted avail) + -- 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. + -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a) + -- Note that we pass the superclasses to the dfun, so they will be "wanted". + -- If we put the superclasses of "d" in avails, then we might end up + -- expressing "d1" in terms of "d", which would be a disaster. + where + avail = Avail (instToId wanted) rhs [] + + rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection + | otherwise = NoRhs + +addFree :: Avails s -> Inst s -> (Avails s) + -- When an Inst is tossed upstairs as 'free' we nevertheless add it + -- to avails, so that any other equal Insts will be commoned up right + -- here rather than also being tossed upstairs. +addFree avails free + | isDict free = addToFM avails free (Avail (instToId free) NoRhs []) + | otherwise = avails + +addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s) +addGiven avails given + = -- ASSERT( not (given `elemFM` avails) ) + -- This assertion isn't necessarily true. It's permitted + -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...) + -- and when typechecking instance decls we generate redundant "givens" too. + addAvail avails given avail + where + avail = Avail (instToId given) NoRhs [] +addAvail avails wanted avail + = addSuperClasses (addToFM avails wanted avail) wanted + +addSuperClasses :: Avails s -> Inst s -> NF_TcM s (Avails s) + -- Add all the superclasses of the Inst to Avails + -- Invariant: the Inst is already in Avails. + +addSuperClasses avails dict + | not (isDict dict) + = returnNF_Tc avails + + | otherwise -- It is a dictionary + = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) + where + (clas, tys) = getDictClassTys dict + + (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas + sc_theta' = substFlexiTheta (zipVarEnv tyvars tys) sc_theta + + add_sc avails ((super_clas, super_tys), sc_sel) + = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict -> + let + sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel)) + tys) + [instToId dict] + in + case lookupFM avails super_dict of + + Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) -> + -- Already there, but not as a superclass selector + -- No need to look at its superclasses; since it's there + -- already they must be already in avails + -- However, we must remember to activate the dictionary + -- from which it is (now) generated + returnNF_Tc (activate avails' dict) + where + avails' = addToFM avails super_dict avail + avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection + + Just (Avail _ _ _) -> returnNF_Tc avails + -- Already there; no need to do anything + + Nothing -> + -- Not there at all, so add it, and its superclasses + addAvail avails super_dict avail + where + avail = Avail (instToId super_dict) + (PassiveScSel sc_sel_rhs [dict]) + [] +\end{code} %************************************************************************ %* * @@ -475,16 +694,31 @@ Much simpler versions when there are no bindings to make! @deriving@ declarations and when specialising instances. We are only interested in the simplified bunch of class/type constraints. +It simplifies to constraints of the form (C a b c) where +a,b,c are type variables. This is required for the context of +instance declarations. + \begin{code} tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv - -> [(Class, TauType)] -- Given - -> [(Class, TauType)] -- Wanted - -> TcM s [(Class, TauType)] + -> ThetaType -- Wanted + -> TcM s ThetaType -- Needed; of the form C a b c + -- where a,b,c are type variables - -tcSimplifyThetas inst_mapper given wanted - = elimTyConsSimple inst_mapper wanted `thenTc` \ wanted1 -> - returnTc (elimSCsSimple given wanted1) +tcSimplifyThetas inst_mapper wanteds + = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds -> + let + -- Check that the returned dictionaries are of the form (C a b c) + bad_guys | opt_GlasgowExts = [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 + else + mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_` + failTc \end{code} @tcSimplifyCheckThetas@ just checks class-type constraints, essentially; @@ -492,55 +726,84 @@ used with \tr{default} declarations. We are only interested in whether it worked or not. \begin{code} -tcSimplifyCheckThetas :: [(Class, TauType)] -- Simplify this to nothing at all +tcSimplifyCheckThetas :: ThetaType -- Given + -> ThetaType -- Wanted -> TcM s () -tcSimplifyCheckThetas theta - = elimTyConsSimple classInstEnv theta `thenTc` \ theta1 -> - ASSERT( null theta1 ) - returnTc () +tcSimplifyCheckThetas givens wanteds + = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds -> + if null irreds then + returnTc () + else + mapNF_Tc addNoInstErr irreds `thenNF_Tc_` + failTc \end{code} \begin{code} -elimTyConsSimple :: (Class -> ClassInstEnv) - -> [(Class,Type)] - -> TcM s [(Class,Type)] -elimTyConsSimple inst_mapper theta - = elim theta +type AvailsSimple = FiniteMap (Class, [TauType]) Bool + -- True => irreducible + -- False => given, or can be derived from a given or from an irreducible + +reduceSimple :: (Class -> ClassInstEnv) + -> ThetaType -- Given + -> ThetaType -- Wanted + -> NF_TcM s ThetaType -- Irreducible + +reduceSimple inst_mapper givens wanteds + = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' -> + returnNF_Tc [ct | (ct,True) <- fmToList givens_fm'] where - elim [] = returnTc [] - elim ((clas,ty):rest) = elim_one clas ty `thenTc` \ r1 -> - elim rest `thenTc` \ r2 -> - returnTc (r1++r2) - - elim_one clas ty - = case getTyVar_maybe ty of - - Just tv -> returnTc [(clas,ty)] - - otherwise -> recoverTc (returnTc []) $ - lookupSimpleInst (inst_mapper clas) clas ty `thenTc` \ theta -> - elim theta - -elimSCsSimple :: [(Class,Type)] -- Given - -> [(Class,Type)] -- Wanted - -> [(Class,Type)] -- Subset of wanted; no dups, no subclass relnships - -elimSCsSimple givens [] = [] -elimSCsSimple givens (c_t@(clas,ty) : rest) - | any (`subsumes` c_t) givens || - any (`subsumes` c_t) rest -- (clas,ty) is old hat - = elimSCsSimple givens rest - | otherwise -- (clas,ty) is new - = c_t : elimSCsSimple (c_t : givens) rest + givens_fm = foldl addNonIrred emptyFM givens + +reduce_simple :: (Int,ThetaType) -- Stack + -> (Class -> ClassInstEnv) + -> AvailsSimple + -> ThetaType + -> NF_TcM s AvailsSimple + +reduce_simple (n,stack) inst_mapper avails wanteds + = go avails wanteds where - rest' = elimSCsSimple rest - (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 && - (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1)) --- We deal with duplicates here ^^^^^^^^ --- It's a simple place to do it, although it's done in elimTyCons in the --- full-blown version of the simpifier. + 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' ws + +reduce_simple_help stack inst_mapper givens wanted@(clas,tys) + | wanted `elemFM` givens + = returnNF_Tc givens + + | otherwise + = lookupSimpleInst (inst_mapper clas) 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 + +addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple +addIrred givens ct + = addSCs (addToFM givens ct True) ct + +addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple +addNonIrred givens ct + = addSCs (addToFM givens ct False) ct + +addSCs givens ct@(clas,tys) + = foldl add givens sc_theta + where + (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas + sc_theta = substFlexiTheta (zipVarEnv tyvars tys) sc_theta_tmpl + + add givens ct = case lookupFM givens ct of + Nothing -> -- Add it and its superclasses + addSCs (addToFM givens ct False) ct + + Just True -> -- Set its flag to False; superclasses already done + addToFM givens ct False + + Just False -> -- Already done + givens + \end{code} %************************************************************************ @@ -572,19 +835,30 @@ For each method @Inst@ in the @init_lie@ that mentions one of the bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s) bindInstsOfLocalFuns init_lie local_ids - = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie) - where - bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds) - | id `is_elem` local_ids - = lookupInst inst `thenTc` \ (dict_insts, (id,rhs)) -> - returnTc (listToBag dict_insts `plusLIE` insts, - VarMonoBind id rhs `AndMonoBinds` binds) + | null overloaded_ids || null lie_for_here + -- Common case + = returnTc (init_lie, EmptyMonoBinds) - bind_inst some_other_inst (insts, binds) - -- Either not a method, or a method instance for an id not in local_ids - = returnTc (some_other_inst `consBag` insts, binds) - - is_elem = isIn "bindInstsOfLocalFuns" + | otherwise + = reduceContext (text "bindInsts" <+> ppr local_ids) + try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) -> + ASSERT( null irreds ) + returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds) + where + overloaded_ids = filter is_overloaded local_ids + is_overloaded id = case splitSigmaTy (idType id) of + (_, theta, _) -> not (null theta) + + overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them + -- so it's worth building a set, so that + -- lookup (in isMethodFor) is faster + + -- No sense in repeatedly zonking lots of + -- constant constraints so filter them out here + (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set) + (bagToList init_lie) + try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds + | otherwise = Free \end{code} @@ -624,23 +898,56 @@ dictionaries and either resolves them (producing bindings) or complains. It works by splitting the dictionary list by type variable, and using @disambigOne@ to do the real business. -IMPORTANT: @disambiguate@ assumes that its argument dictionaries -constrain only a simple type variable. + +@tcSimplifyTop@ is called once per module to simplify +all the constant and ambiguous Insts. \begin{code} -type SimpleDictInfo s = (Inst s, Class, TcTyVar s) +tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s) +tcSimplifyTop wanted_lie + = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) -> + ASSERT( null frees ) -disambiguateDicts :: LIE s -> TcM s () + let + -- All the non-std ones are definite errors + (stds, non_stds) = partition isStdClassTyVarDict irreds + + + -- Group by type variable + std_groups = equivClasses cmp_by_tyvar stds + + -- Pick the ones which its worth trying to disambiguate + (std_oks, std_bads) = partition worth_a_try std_groups + -- Have a try at disambiguation + -- if the type variable isn't bound + -- up with one of the non-standard classes + worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars) + non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds) + + -- 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 -> + + -- And complain about the ones that don't + mapNF_Tc complain bad_guys `thenNF_Tc_` -disambiguateDicts insts - = mapTc disambigOne inst_infos `thenTc` \ binds_lists -> - returnTc () + returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig) where - inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts)) - (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2 + wanteds = bagToList wanted_lie + try_me inst = ReduceMe AddToIrreds + + d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 + + complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d + | otherwise = addAmbigErr tyVarsOfInst d - mk_inst_info dict@(Dict _ clas ty _ _) - = (dict, clas, getTyVar "disambiguateDicts" ty) +get_tv d = case getDictClassTys d of + (clas, [ty]) -> getTyVar "tcSimplifyTop" ty +get_clas d = case getDictClassTys d of + (clas, [ty]) -> clas \end{code} @disambigOne@ assumes that its arguments dictionaries constrain all @@ -656,10 +963,11 @@ Since we're not using the result of @foo@, the result if (presumably) @void@. \begin{code} -disambigOne :: [SimpleDictInfo s] -> TcM s () +disambigGroup :: [Inst s] -- All standard classes of form (C a) + -> TcM s (TcDictBinds s) -disambigOne dict_infos - | any isNumericClass classes && all isStandardClass classes +disambigGroup dicts + | any isNumericClass classes -- Guaranteed all standard classes = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT -- SO, TRY DEFAULT TYPES IN ORDER @@ -670,34 +978,47 @@ disambigOne dict_infos tcGetDefaultTys `thenNF_Tc` \ default_tys -> let try_default [] -- No defaults work, so fail - = failTc (ambigErr dicts) + = failTc try_default (default_ty : default_tys) = tryTc (try_default default_tys) $ -- If default_ty fails, we try -- default_tys instead - tcSimplifyCheckThetas thetas `thenTc` \ _ -> + tcSimplifyCheckThetas [] thetas `thenTc` \ _ -> returnTc default_ty where - thetas = classes `zip` repeat default_ty + thetas = classes `zip` repeat [default_ty] in -- See if any default works, and if so bind the type variable to it - try_default default_tys `thenTc` \ chosen_default_ty -> - tcInstType [] chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome! - unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) + -- If not, add an AmbigErr + recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $ + + 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_` + reduceContext (text "disambig" <+> ppr dicts) + try_me [] dicts `thenTc` \ (binds, frees, ambigs) -> + ASSERT( null frees && null ambigs ) + returnTc binds - | all isCcallishClass classes + | all isCreturnableClass classes = -- Default CCall stuff to (); we don't even both to check that () is an - -- instance of CCallable/CReturnable, because we know it is. - unifyTauTy (mkTyVarTy tyvar) unitTy + -- instance of CReturnable, because we know it is. + unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_` + returnTc EmptyMonoBinds | otherwise -- No defaults - = failTc (ambigErr dicts) + = complain dicts `thenNF_Tc_` + returnTc EmptyMonoBinds where - (_,_,tyvar) = head dict_infos -- Should be non-empty - dicts = [dict | (dict,_,_) <- dict_infos] - classes = [clas | (_,clas,_) <- dict_infos] - + complain = addAmbigErrs tyVarsOfInst + try_me inst = ReduceMe AddToIrreds -- This reduce should not fail + tyvar = get_tv (head dicts) -- Should be non-empty + classes = map get_clas dicts \end{code} @@ -709,23 +1030,58 @@ from the insts, or just whatever seems to be around in the monad just now? \begin{code} -genCantGenErr insts sty -- Can't generalise these Insts - = ppHang (ppPStr SLIT("Cannot generalise these overloadings (in a _ccall_):")) - 4 (ppAboves (map (ppr sty) (bagToList insts))) -\end{code} +genCantGenErr insts -- Can't generalise these Insts + = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"), + nest 4 (pprInstsInFull insts) + ] + +addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts + +addAmbigErr ambig_tv_fn dict + = tcAddSrcLoc (instLoc dict) $ + addErrTcM (tidy_env, + sep [text "Ambiguous type variable(s)" <+> + hsep (punctuate comma (map (quotes . ppr) ambig_tvs)), + nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict)), + nest 4 (pprOrigin dict)]) + where + ambig_tvs = varSetElems (ambig_tv_fn tidy_dict) + (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict + +-- Used for top-level irreducibles +addTopInstanceErr dict + = tcAddSrcLoc (instLoc dict) $ + addErrTcM (tidy_env, + sep [ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict), + nest 4 $ pprOrigin dict]) + where + (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict + +addNoInstanceErr str givens dict + = tcAddSrcLoc (instLoc dict) $ + addErrTcM (tidy_env, + sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict), + nest 4 $ parens $ pprOrigin dict], + nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens] + $$ + ptext SLIT("Probable cause:") <+> + vcat [ptext SLIT("missing") <+> quotes (pprInst tidy_dict) <+> ptext SLIT("in") <+> str, + if 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) -\begin{code} -ambigErr insts sty - = ppAboves (map (pprInst sty "Ambiguous overloading") insts) -\end{code} +-- Used for the ...Thetas variants; all top level +addNoInstErr (c,ts) + = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts)) -@reduceErr@ complains if we can't express required dictionaries in -terms of the signature. +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"), + nest 4 (pprInstsInFull stack)] -\begin{code} -reduceErr insts sty - = ppAboves (map (pprInst sty "Context required by inferred type, but missing on a type signature") - (bagToList insts)) +reduceDepthMsg n stack = nest 4 (pprInstsInFull stack) \end{code} - -