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, isClassDict, isStdClassTyVarDict,
- isMethodFor, notFunDep,
+ isDict, isClassDict, isMethod, notFunDep,
+ isStdClassTyVarDict, isMethodFor,
instToId, instBindingRequired, instCanBeGeneralised,
- newDictFromOld,
+ newDictFromOld, newFunDepFromDict,
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 Maybe ( fromJust )
+import Maybes ( maybeToBool )
\end{code}
-- Finished
returnTc (mkLIE frees, binds, mkLIE irreds')
where
- -- the idea behind filtering out the dependencies here is that
- -- they've already served their purpose, and can be reconstructed
- -- at a later point from the retained class predicates.
- -- however, there *is* the possibility that a dependency
- -- out-lives the predicate from which it arose.
- -- I don't have any examples of this, but if they show up,
- -- we'd want to consider the possibility of saving the
- -- dependencies as hidden constraints (i.e. they'd only
- -- show up in interface files) -- or maybe they'd be useful
- -- as first class predicates...
- wanteds = filter notFunDep (lieToList wanted_lie)
+ wanteds = lieToList wanted_lie
try_me inst
-- Does not constrain a local tyvar
-- 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
+ | isClassDict inst = DontReduceUnlessConstant -- Dicts
+ | otherwise = ReduceMe AddToIrreds -- Lits and Methods
\end{code}
@tcSimplifyAndCheck@ is similar to the above, except that it checks
returnTc (mkLIE frees, binds)
where
givens = lieToList given_lie
- -- see comment on wanteds in tcSimplify
- wanteds = filter notFunDep (lieToList wanted_lie)
+ wanteds = lieToList wanted_lie
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))
+ && (not (isMethod inst) || null (getIPs inst))
= Free
-- When checking against a given signature we always reduce
ASSERT( null frees )
returnTc (mkLIE irreds, binds)
where
- -- see comment on wanteds in tcSimplify
- 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
= -- Zonking first
mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
+ -- JRL - process fundeps last. We eliminate fundeps by seeing
+ -- what available classes generate them, so we need to process the
+ -- classes first. (would it be useful to make LIEs ordered in the first place?)
+ let (wantedOther, wantedFds) = partition notFunDep wanteds
+ wanteds' = wantedOther ++ wantedFds in
{-
pprTrace "reduceContext" (vcat [
]) $
-}
-- Build the Avail mapping from "givens"
- foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
+ foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
-- Do the real work
- reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
+ reduceList (0,[]) try_me wanteds' (avails, [], []) `thenNF_Tc` \ (avails, frees, irreds) ->
-- Extract the bindings from avails
let
text "----------------------"
]) $
-}
- returnTc (binds, frees, irreds)
+ returnNF_Tc (binds, frees, irreds)
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
;
- 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
addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
-- Add all the superclasses of the Inst to Avails
+ -- JRL - also add in the functional dependencies
-- Invariant: the Inst is already in Avails.
addSuperClasses avails dict
= returnNF_Tc avails
| otherwise -- It is a dictionary
- = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
+ = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' ->
+ newFunDepFromDict dict `thenNF_Tc` \ fdInst_maybe ->
+ case fdInst_maybe of
+ Nothing -> returnNF_Tc avails'
+ Just fdInst ->
+ let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in
+ addAvail avails fdInst fdAvail
where
(clas, tys) = getDictClassTys dict
-
(tyvars, sc_theta, sc_sels, _) = classBigSig clas
sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
where
- -- see comment on wanteds in tcSimplify
- wanteds = filter notFunDep (lieToList wanted_lie)
+ wanteds = lieToList wanted_lie
try_me inst = ReduceMe AddToIrreds
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
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)
projects / ghc-hetmet.git / blobdiff