%
-% (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 HsBinds ( andMonoBinds )
-import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr),
- SYN_IE(TcMonoBinds), SYN_IE(TcDictBinds) )
+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 ( PprStyle, Outputable(..){-instance * []-} )
-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
- TcMonoBinds 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, sc_binds `AndMonoBinds` 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 => <type not involving x>
+
+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] => <type not involving 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
\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
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
\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
TcDictBinds 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}
+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)
-@tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
-is not overloaded.
+ | otherwise
+ = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
-\begin{code}
-tcSimplifyRank2 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
- -> LIE s -- Given
- -> TcM s (LIE s, -- Free
- TcDictBinds s) -- Bindings
+ -- Complain about any irreducible ones
+ mapNF_Tc complain irreds `thenNF_Tc_`
+ -- Done
+ returnTc (mkLIE frees, binds)
+ where
+ givens = bagToList given_lie
+ wanteds = bagToList wanted_lie
-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) ->
+ try_me inst
+ -- Does not constrain a local tyvar
+ | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
+ = Free
- checkTc (isEmptyBag wanteds) (reduceErr wanteds) `thenTc_`
+ -- When checking against a given signature we always reduce
+ -- until we find a match against something given, or can't reduce
+ | otherwise
+ = ReduceMe AddToIrreds
- returnTc (free, dict_binds)
+ complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
+ addNoInstanceErr str givens dict
\end{code}
-@tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
-mechansim with the extra flag to say ``beat out constant insts''.
-
-\begin{code}
-tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
-tcSimplifyTop dicts
- = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) ->
- returnTc binds
-\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
- TcDictBinds 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 <simpler-wanted-binds> in
- let wanted = rhs in
- let <yet-more-bindings> ...
\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, TcDictBinds s, LIE s)
-
- eTC givens [] = returnTc (givens, emptyBag, EmptyMonoBinds, 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 = (VarMonoBind (instToId wanted) (HsVar (instToId this)))
- `AndMonoBinds` 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, EmptyMonoBinds, 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 `AndMonoBinds` 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@(VarMonoBind _ 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, EmptyMonoBinds, 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 `AndMonoBinds` 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 "<no rhs>"
+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 (TcDictBinds 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 (TcDictBinds s, -- Bindings
- LIE s) -- Minimal wanted set
-
-elimSCs_help given [] = returnNF_Tc (EmptyMonoBinds, 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 `AndMonoBinds` binds2, irreds1 `plusLIE` irreds2)
-
-
-trySC :: LIE s -- Givens
- -> Inst s -- Wanted
- -> NF_TcM s (LIE s, -- New givens,
- TcDictBinds 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), EmptyMonoBinds, 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),
- (VarMonoBind (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,
- andMonoBinds 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}
%************************************************************************
%* *
@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;
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}
%************************************************************************
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, bind) ->
- returnTc (listToBag dict_insts `plusLIE` insts,
- bind `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}
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 ->
-disambiguateDicts insts
- = mapTc disambigOne inst_infos `thenTc` \ binds_lists ->
- returnTc ()
+ -- And complain about the ones that don't
+ mapNF_Tc complain bad_guys `thenNF_Tc_`
+
+ 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
@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
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}
now?
\begin{code}
-genCantGenErr insts sty -- Can't generalise these Insts
- = hang (ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"))
- 4 (vcat (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
- = hang (ptext SLIT("Ambiguous overloading"))
- 4 (vcat (map (pprInst sty) 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
- = hang (ptext (SLIT("Context required by inferred type, but missing on a type signature")))
- 4 (vcat (map (pprInst sty) (bagToList insts)))
+reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
\end{code}
-
-
projects / ghc-hetmet.git / blobdiff