\begin{code}
module TcSimplify (
- tcSimplify, tcSimplifyAndCheck, tcSimplifyRuleLhs,
+ tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts,
tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
bindInstsOfLocalFuns
) where
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
- tyVarsOfInst,
- isDict, isStdClassTyVarDict, isMethodFor,
+ tyVarsOfInst, tyVarsOfInsts,
+ isDict, isClassDict, isStdClassTyVarDict,
+ isMethodFor, notFunDep,
instToId, instBindingRequired, instCanBeGeneralised,
newDictFromOld,
- instLoc, getDictClassTys,
- pprInst, zonkInst, tidyInst, tidyInsts,
- Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE,
- plusLIE, pprOrigin
+ getDictClassTys, getIPs,
+ instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
+ Inst, LIE, pprInsts, pprInstsInFull,
+ mkLIE, emptyLIE, plusLIE, lieToList
)
import TcEnv ( tcGetGlobalTyVars )
import TcType ( TcType, TcTyVarSet, typeToTcType )
import TcUnify ( unifyTauTy )
import Id ( idType )
-import Bag ( bagToList )
import Class ( Class, classBigSig, classInstEnv )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
-import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
+import Type ( Type, ThetaType, TauType, ClassContext,
+ mkTyVarTy, getTyVar,
isTyVarTy, splitSigmaTy, tyVarsOfTypes
)
import InstEnv ( InstEnv )
-import Subst ( mkTopTyVarSubst, substTheta )
+import Subst ( mkTopTyVarSubst, substClasses )
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
import VarSet
\begin{code}
tcSimplify
:: SDoc
- -> TopLevelFlag
-> TcTyVarSet -- ``Local'' type variables
-- ASSERT: this tyvar set is already zonked
-> LIE -- Wanted
TcDictBinds, -- Bindings
LIE) -- Remaining wanteds; no dups
-tcSimplify str top_lvl local_tvs wanted_lie
+tcSimplify str 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
-- Finished
returnTc (mkLIE frees, binds, mkLIE irreds')
where
- wanteds = bagToList wanted_lie
+ -- 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)
try_me inst
-- Does not constrain a local tyvar
| isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
+ && null (getIPs inst)
= -- if is_top_level then
-- FreeIfTautological -- Special case for inference on
-- -- top-level defns
-- Done
returnTc (mkLIE frees, binds)
where
- givens = bagToList given_lie
- wanteds = bagToList wanted_lie
- given_dicts = filter isDict givens
+ givens = lieToList given_lie
+ -- see comment on wanteds in tcSimplify
+ wanteds = filter notFunDep (lieToList wanted_lie)
+ given_dicts = filter isClassDict givens
try_me inst
-- Does not constrain a local tyvar
getting dictionaries. We want to keep all of them unsimplified, to serve
as the available stuff for the RHS of the rule.
+The same thing is used for specialise pragmas. Consider
+
+ f :: Num a => a -> a
+ {-# SPECIALISE f :: Int -> Int #-}
+ f = ...
+
+The type checker generates a binding like:
+
+ f_spec = (f :: Int -> Int)
+
+and we want to end up with
+
+ f_spec = _inline_me_ (f Int dNumInt)
+
+But that means that we must simplify the Method for f to (f Int dNumInt)!
+So tcSimplifyToDicts squeezes out all Methods.
+
\begin{code}
-tcSimplifyRuleLhs :: LIE -> TcM s (LIE, TcDictBinds)
-tcSimplifyRuleLhs wanted_lie
- = reduceContext (text "tcSimplRuleLhs") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
+tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds)
+tcSimplifyToDicts wanted_lie
+ = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
ASSERT( null frees )
returnTc (mkLIE irreds, binds)
where
- wanteds = bagToList wanted_lie
+ -- see comment on wanteds in tcSimplify
+ wanteds = filter notFunDep (lieToList wanted_lie)
-- Reduce methods and lits only; stop as soon as we get a dictionary
try_me inst | isDict inst = DontReduce
\end{code}
+
%************************************************************************
%* *
\subsection{Data types for the reduction mechanism}
-- Invariant: these Insts are already in the finite mapping
-pprAvails avails = vcat (map pp (eltsFM avails))
- where
- pp (Avail main_id rhs ids)
- = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
+pprAvails avails = vcat (map pprAvail (eltsFM avails))
+
+pprAvail (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
-- 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
+ -- addAvail avails given avail
+ addAvail avails given avail `thenNF_Tc` \av ->
+ zonkInst given `thenNF_Tc` \given' ->
+ returnNF_Tc av
where
avail = Avail (instToId given) NoRhs []
-- Invariant: the Inst is already in Avails.
addSuperClasses avails dict
- | not (isDict dict)
+ | not (isClassDict dict)
= returnNF_Tc avails
| otherwise -- It is a dictionary
where
(clas, tys) = getDictClassTys dict
- (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
- sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
+ (tyvars, sc_theta, sc_sels, _) = classBigSig clas
+ sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
add_sc avails ((super_clas, super_tys), sc_sel)
= newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
\begin{code}
tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv
- -> ThetaType -- Wanted
- -> TcM s ThetaType -- Needed
+ -> ClassContext -- Wanted
+ -> TcM s ClassContext -- Needed
tcSimplifyThetas inst_mapper wanteds
= reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
whether it worked or not.
\begin{code}
-tcSimplifyCheckThetas :: ThetaType -- Given
- -> ThetaType -- Wanted
+tcSimplifyCheckThetas :: ClassContext -- Given
+ -> ClassContext -- Wanted
-> TcM s ()
tcSimplifyCheckThetas givens wanteds
\begin{code}
-type AvailsSimple = FiniteMap (Class, [TauType]) Bool
+type AvailsSimple = FiniteMap (Class,[Type]) Bool
-- True => irreducible
-- False => given, or can be derived from a given or from an irreducible
reduceSimple :: (Class -> InstEnv)
- -> ThetaType -- Given
- -> ThetaType -- Wanted
- -> NF_TcM s ThetaType -- Irreducible
+ -> ClassContext -- Given
+ -> ClassContext -- Wanted
+ -> NF_TcM s ClassContext -- Irreducible
reduceSimple inst_mapper givens wanteds
= reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
where
givens_fm = foldl addNonIrred emptyFM givens
-reduce_simple :: (Int,ThetaType) -- Stack
+reduce_simple :: (Int,ClassContext) -- Stack
-> (Class -> InstEnv)
-> AvailsSimple
- -> ThetaType
+ -> ClassContext
-> NF_TcM s AvailsSimple
reduce_simple (n,stack) inst_mapper avails wanteds
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
+addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
+addIrred givens ct@(clas,tys)
= addSCs (addToFM givens ct True) ct
-addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
-addNonIrred givens ct
+addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
+addNonIrred givens ct@(clas,tys)
= 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 = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
+ (tyvars, sc_theta_tmpl, _, _) = classBigSig clas
+ sc_theta = substClasses (mkTopTyVarSubst 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
+ add givens ct@(clas, tys)
+ = 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 True -> -- Set its flag to False; superclasses already done
+ addToFM givens ct False
- Just False -> -- Already done
- givens
+ Just False -> -- Already done
+ givens
\end{code}
-- 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)
+ (lieToList init_lie)
try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
| otherwise = Free
\end{code}
returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
where
- wanteds = bagToList wanted_lie
+ -- see comment on wanteds in tcSimplify
+ wanteds = filter notFunDep (lieToList 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
+ complain d | not (null (getIPs d)) = addTopIPErr d
+ | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
| otherwise = addAmbigErr tyVarsOfInst d
get_tv d = case getDictClassTys d of
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)" <+>
+ = addInstErrTcM (instLoc dict)
+ (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)])
+ nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
where
ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
(tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
= returnNF_Tc ()
| otherwise
- = tcAddSrcLoc (instLoc (head dicts)) $
- warnTc True msg
+ = warnTc True msg
where
msg | length dicts > 1
= (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
(_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
addRuleLhsErr dict
- = tcAddSrcLoc (instLoc dict) $
- addErrTcM (tidy_env,
- vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
- nest 4 (pprOrigin dict),
- ptext SLIT("LHS of a rule must have no overloading")])
+ = addInstErrTcM (instLoc dict)
+ (tidy_env,
+ vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
+ nest 4 (ptext SLIT("LHS of a rule must have no overloading"))])
+ where
+ (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
+
+addTopIPErr dict
+ = addInstErrTcM (instLoc dict)
+ (tidy_env,
+ ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
where
(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])
+ = addInstErrTcM (instLoc dict)
+ (tidy_env,
+ ptext SLIT("No instance for") <+> quotes (pprInst tidy_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:") <+>
+ = addInstErrTcM (instLoc dict)
+ (tidy_env,
+ sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
+ nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
+ $$
+ ptext SLIT("Probable cause:") <+>
vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
- ptext SLIT("in") <+> str],
- if all_tyvars then empty else
+ ptext SLIT("in") <+> str],
+ 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