module TcSimplify (
tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts,
tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
- bindInstsOfLocalFuns
+ bindInstsOfLocalFuns, partitionPredsOfLIE
) where
#include "HsVersions.h"
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
tyVarsOfInst, tyVarsOfInsts,
- isDict, isStdClassTyVarDict, isMethodFor, notFunDep,
+ isDict, isClassDict, isStdClassTyVarDict,
+ isMethodFor, notFunDep,
instToId, instBindingRequired, instCanBeGeneralised,
newDictFromOld,
getDictClassTys, getIPs,
+ getDictPred_maybe, getMethodTheta_maybe,
instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
Inst, LIE, pprInsts, pprInstsInFull,
- mkLIE, emptyLIE, plusLIE, lieToList
+ mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
+ lieToList, listToLIE
)
import TcEnv ( tcGetGlobalTyVars )
import TcType ( TcType, TcTyVarSet, typeToTcType )
import Outputable
import Util
import List ( partition )
+import Maybes ( maybeToBool )
\end{code}
LIE) -- Remaining wanteds; no dups
tcSimplify str local_tvs wanted_lie
-{-
+{- this is just an optimization, and interferes with implicit params,
+ disable it for now. same goes for tcSimplifyAndCheck
| isEmptyVarSet local_tvs
= returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
(irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
in
- -- pprTrace "tcS" (ppr (frees, irreds')) $
- -- pprTrace "tcS bad" (ppr bad_guys) $
addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
-- We're infering (not checking) the type, and
-- the inst constrains a local type variable
- | isDict inst = DontReduce -- Dicts
+ | isDict inst = DontReduceUnlessConstant -- Dicts
| otherwise = ReduceMe AddToIrreds -- Lits and Methods
\end{code}
TcDictBinds) -- 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) ->
-- Complain about any irreducible ones
givens = lieToList given_lie
-- see comment on wanteds in tcSimplify
wanteds = filter notFunDep (lieToList wanted_lie)
- given_dicts = filter isDict givens
+ given_dicts = filter isClassDict givens
try_me inst
-- Does not constrain a local tyvar
| isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
+ && (isDict inst || null (getIPs inst))
= Free
-- When checking against a given signature we always reduce
returnTc (mkLIE irreds, binds)
where
-- see comment on wanteds in tcSimplify
- wanteds = filter notFunDep (lieToList wanted_lie)
+ -- ZZ waitaminute - doesn't appear that any funDeps should even be here...
+ -- wanteds = filter notFunDep (lieToList wanted_lie)
+ wanteds = lieToList wanted_lie
-- Reduce methods and lits only; stop as soon as we get a dictionary
try_me inst | isDict inst = DontReduce
| otherwise = ReduceMe AddToIrreds
\end{code}
+The following function partitions a LIE by a predicate defined
+over `Pred'icates (an unfortunate overloading of terminology!).
+This means it sometimes has to split up `Methods', in which case
+a binding is generated.
+
+It is used in `with' bindings to extract from the LIE the implicit
+parameters being bound.
+
+\begin{code}
+partitionPredsOfLIE pred lie
+ = foldlTc (partPreds pred) (emptyLIE, emptyLIE, EmptyMonoBinds) insts
+ where insts = lieToList lie
+
+-- warning: the term `pred' is overloaded here!
+partPreds pred (lie1, lie2, binds) inst
+ | maybeToBool maybe_pred
+ = if pred p then
+ returnTc (consLIE inst lie1, lie2, binds)
+ else
+ returnTc (lie1, consLIE inst lie2, binds)
+ where maybe_pred = getDictPred_maybe inst
+ Just p = maybe_pred
+
+-- the assumption is that those satisfying `pred' are being extracted,
+-- so we leave the method untouched when nothing satisfies `pred'
+partPreds pred (lie1, lie2, binds1) inst
+ | maybeToBool maybe_theta
+ = if any pred theta then
+ zonkInst inst `thenTc` \ inst' ->
+ tcSimplifyToDicts (unitLIE inst') `thenTc` \ (lie3, binds2) ->
+ partitionPredsOfLIE pred lie3 `thenTc` \ (lie1', lie2', EmptyMonoBinds) ->
+ returnTc (lie1 `plusLIE` lie1',
+ lie2 `plusLIE` lie2',
+ binds1 `AndMonoBinds` binds2)
+ else
+ returnTc (lie1, consLIE inst lie2, binds1)
+ where maybe_theta = getMethodTheta_maybe inst
+ Just theta = maybe_theta
+
+partPreds pred (lie1, lie2, binds) inst
+ = returnTc (lie1, consLIE inst lie2, binds)
+\end{code}
%************************************************************************
= ReduceMe -- Try to reduce this
NoInstanceAction -- What to do if there's no such instance
- | DontReduce -- Return as irreducible
+ | DontReduce -- Return as irreducible
+
+ | DontReduceUnlessConstant -- Return as irreducible unless it can
+ -- be reduced to a constant in one step
| Free -- Return as free
pprAvails avails = vcat (map pprAvail (eltsFM avails))
-
+
pprAvail (Avail main_id rhs ids)
= ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
+instance Outputable Avail where
+ ppr = pprAvail
+
pprRhs NoRhs = text "<no rhs>"
pprRhs (Rhs rhs b) = ppr rhs
pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
text "wanted" <+> ppr wanteds,
text "----",
text "avails" <+> pprAvails avails,
+ text "frees" <+> ppr frees,
text "irreds" <+> ppr irreds,
text "----------------------"
]) $
;
- DontReduce -> -- It's irreducible (or at least should not be reduced)
+
+ DontReduce -> add_to_irreds
+ ;
+
+ DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
-- See if the inst can be reduced to a constant in one step
lookupInst wanted `thenNF_Tc` \ lookup_result ->
case lookup_result of
-- Invariant: the Inst is already in Avails.
addSuperClasses avails dict
- | not (isDict dict)
+ | not (isClassDict dict)
= returnNF_Tc avails
| otherwise -- It is a dictionary
addAmbigErr ambig_tv_fn dict
= addInstErrTcM (instLoc dict)
(tidy_env,
- sep [text "Ambiguous type variable(s)" <+>
- hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
+ sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs,
nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
where
ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
ptext SLIT("Probable cause:") <+>
vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
ptext SLIT("in") <+> str],
- if isDict dict && all_tyvars then empty else
+ if isClassDict dict && all_tyvars then empty else
ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
)
where
projects / ghc-hetmet.git / blobdiff