Commit da9a3302 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge ../HEAD

parents f26027ee d6918e90
......@@ -585,26 +585,25 @@ mkGlobalRdrEnv gres
(nameOccName (gre_name gre))
gre
findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]])
findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> [[Name]]
-- ^ For each 'OccName', see if there are multiple local definitions
-- for it. If so, remove all but one (to suppress subsequent error messages)
-- for it; return a list of all such
-- and return a list of the duplicate bindings
findLocalDupsRdrEnv rdr_env occs
= go rdr_env [] occs
where
go rdr_env dups [] = (rdr_env, dups)
go _ dups [] = dups
go rdr_env dups (occ:occs)
= case filter isLocalGRE gres of
[] -> WARN( True, ppr occ <+> ppr rdr_env )
go rdr_env dups occs -- Weird! No binding for occ
[_] -> go rdr_env dups occs -- The common case
dup_gres -> go (extendOccEnv rdr_env occ (head dup_gres : nonlocal_gres))
(map gre_name dup_gres : dups)
occs
[] -> go rdr_env dups occs
[_] -> go rdr_env dups occs -- The common case
dup_gres -> go rdr_env' (map gre_name dup_gres : dups) occs
where
gres = lookupOccEnv rdr_env occ `orElse` []
nonlocal_gres = filterOut isLocalGRE gres
rdr_env' = delFromOccEnv rdr_env occ
-- The delFromOccEnv avoids repeating the same
-- complaint twice, when occs itself has a duplicate
-- which is a common case
insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]
insertGRE new_g [] = [new_g]
......
......@@ -64,6 +64,7 @@ class TrieMap m where
emptyTM :: m a
lookupTM :: forall b. Key m -> m b -> Maybe b
alterTM :: forall b. Key m -> XT b -> m b -> m b
mapTM :: (a->b) -> m a -> m b
foldTM :: (a -> b -> b) -> m a -> b -> b
-- The unusual argument order here makes
......@@ -108,6 +109,7 @@ instance TrieMap IntMap.IntMap where
lookupTM k m = IntMap.lookup k m
alterTM = xtInt
foldTM k m z = IntMap.fold k z m
mapTM f m = IntMap.map f m
xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a
xtInt k f m = IntMap.alter f k m
......@@ -118,6 +120,7 @@ instance Ord k => TrieMap (Map.Map k) where
lookupTM = Map.lookup
alterTM k f m = Map.alter f k m
foldTM k m z = Map.fold k z m
mapTM f m = Map.map f m
instance TrieMap UniqFM where
type Key UniqFM = Unique
......@@ -125,6 +128,7 @@ instance TrieMap UniqFM where
lookupTM k m = lookupUFM m k
alterTM k f m = alterUFM f m k
foldTM k m z = foldUFM k z m
mapTM f m = mapUFM f m
\end{code}
......@@ -146,6 +150,11 @@ instance TrieMap m => TrieMap (MaybeMap m) where
lookupTM = lkMaybe lookupTM
alterTM = xtMaybe alterTM
foldTM = fdMaybe
mapTM = mapMb
mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b
mapMb f (MM { mm_nothing = mn, mm_just = mj })
= MM { mm_nothing = fmap f mn, mm_just = mapTM f mj }
lkMaybe :: TrieMap m => (forall b. k -> m b -> Maybe b)
-> Maybe k -> MaybeMap m a -> Maybe a
......@@ -170,8 +179,13 @@ instance TrieMap m => TrieMap (ListMap m) where
type Key (ListMap m) = [Key m]
emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM }
lookupTM = lkList lookupTM
alterTM = xtList alterTM
alterTM = xtList alterTM
foldTM = fdList
mapTM = mapList
mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b
mapList f (LM { lm_nil = mnil, lm_cons = mcons })
= LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons }
lkList :: TrieMap m => (forall b. k -> m b -> Maybe b)
-> [k] -> ListMap m a -> Maybe a
......@@ -263,7 +277,7 @@ data CoreMap a
, cm_co :: CoercionMap a
, cm_type :: TypeMap a
, cm_cast :: CoreMap (CoercionMap a)
, cm_tick :: CoreMap (TickishMap a)
, cm_tick :: CoreMap (TickishMap a)
, cm_app :: CoreMap (CoreMap a)
, cm_lam :: CoreMap (TypeMap a) -- Note [Binders]
, cm_letn :: CoreMap (CoreMap (BndrMap a))
......@@ -285,8 +299,25 @@ instance TrieMap CoreMap where
type Key CoreMap = CoreExpr
emptyTM = EmptyCM
lookupTM = lkE emptyCME
alterTM = xtE emptyCME
alterTM = xtE emptyCME
foldTM = fdE
mapTM = mapE
--------------------------
mapE :: (a->b) -> CoreMap a -> CoreMap b
mapE _ EmptyCM = EmptyCM
mapE f (CM { cm_var = cvar, cm_lit = clit
, cm_co = cco, cm_type = ctype
, cm_cast = ccast , cm_app = capp
, cm_lam = clam, cm_letn = cletn
, cm_letr = cletr, cm_case = ccase
, cm_ecase = cecase, cm_tick = ctick })
= CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit
, cm_co = mapTM f cco, cm_type = mapTM f ctype
, cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp
, cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn
, cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase
, cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }
--------------------------
lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a
......@@ -393,9 +424,16 @@ instance TrieMap AltMap where
, am_data = emptyNameEnv
, am_lit = emptyLiteralMap }
lookupTM = lkA emptyCME
alterTM = xtA emptyCME
foldTM = fdA
alterTM = xtA emptyCME
foldTM = fdA
mapTM = mapA
mapA :: (a->b) -> AltMap a -> AltMap b
mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
= AM { am_deflt = mapTM f adeflt
, am_data = mapNameEnv (mapTM f) adata
, am_lit = mapTM (mapTM f) alit }
lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a
lkA env (DEFAULT, _, rhs) = am_deflt >.> lkE env rhs
lkA env (LitAlt lit, _, rhs) = am_lit >.> lkLit lit >=> lkE env rhs
......@@ -445,8 +483,28 @@ instance TrieMap CoercionMap where
type Key CoercionMap = Coercion
emptyTM = EmptyKM
lookupTM = lkC emptyCME
alterTM = xtC emptyCME
foldTM = fdC
alterTM = xtC emptyCME
foldTM = fdC
mapTM = mapC
mapC :: (a->b) -> CoercionMap a -> CoercionMap b
mapC _ EmptyKM = EmptyKM
mapC f (KM { km_refl = krefl, km_tc_app = ktc
, km_app = kapp, km_forall = kforall
, km_var = kvar, km_axiom = kax
, km_unsafe = kunsafe, km_sym = ksym, km_trans = ktrans
, km_nth = knth, km_inst = kinst })
= KM { km_refl = mapTM f krefl
, km_tc_app = mapNameEnv (mapTM f) ktc
, km_app = mapTM (mapTM f) kapp
, km_forall = mapTM (mapTM f) kforall
, km_var = mapTM f kvar
, km_axiom = mapNameEnv (mapTM f) kax
, km_unsafe = mapTM (mapTM f) kunsafe
, km_sym = mapTM f ksym
, km_trans = mapTM (mapTM f) ktrans
, km_nth = IntMap.map (mapTM f) knth
, km_inst = mapTM (mapTM f) kinst }
lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a
lkC env co m
......@@ -532,8 +590,20 @@ instance TrieMap TypeMap where
type Key TypeMap = Type
emptyTM = EmptyTM
lookupTM = lkT emptyCME
alterTM = xtT emptyCME
foldTM = fdT
alterTM = xtT emptyCME
foldTM = fdT
mapTM = mapT
mapT :: (a->b) -> TypeMap a -> TypeMap b
mapT _ EmptyTM = EmptyTM
mapT f (TM { tm_var = tvar, tm_app = tapp, tm_fun = tfun
, tm_tc_app = ttcapp, tm_forall = tforall, tm_tylit = tlit })
= TM { tm_var = mapTM f tvar
, tm_app = mapTM (mapTM f) tapp
, tm_fun = mapTM (mapTM f) tfun
, tm_tc_app = mapNameEnv (mapTM f) ttcapp
, tm_forall = mapTM (mapTM f) tforall
, tm_tylit = mapTM f tlit }
-----------------
lkT :: CmEnv -> Type -> TypeMap a -> Maybe a
......@@ -615,9 +685,21 @@ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
, tlm_string :: Map.Map FastString a
}
instance TrieMap TyLitMap where
type Key TyLitMap = TyLit
emptyTM = emptyTyLitMap
lookupTM = lkTyLit
alterTM = xtTyLit
foldTM = foldTyLit
mapTM = mapTyLit
emptyTyLitMap :: TyLitMap a
emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty }
mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b
mapTyLit f (TLM { tlm_number = tn, tlm_string = ts })
= TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts }
lkTyLit :: TyLit -> TyLitMap a -> Maybe a
lkTyLit l =
case l of
......@@ -677,10 +759,15 @@ data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable
instance TrieMap VarMap where
type Key VarMap = Var
emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyVarEnv }
emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyVarEnv }
lookupTM = lkVar emptyCME
alterTM = xtVar emptyCME
foldTM = fdVar
alterTM = xtVar emptyCME
foldTM = fdVar
mapTM = mapVar
mapVar :: (a->b) -> VarMap a -> VarMap b
mapVar f (VM { vm_bvar = bv, vm_fvar = fv })
= VM { vm_bvar = mapTM f bv, vm_fvar = mapVarEnv f fv }
lkVar :: CmEnv -> Var -> VarMap a -> Maybe a
lkVar env v
......
......@@ -1116,7 +1116,8 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
then NameNotInScope1
else NameNotInScope2
| otherwise = panic "mkPrintUnqualified"
| otherwise = NameNotInScope1 -- Can happen if 'f' is bound twice in the module
-- Eg f = True; g = 0; f = False
where
mod = nameModule name
occ = nameOccName name
......
......@@ -1597,11 +1597,14 @@ addUnusedWarning name span msg
\begin{code}
addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
addNameClashErrRn rdr_name names
addNameClashErrRn rdr_name gres
| all isLocalGRE gres -- If there are two or more *local* defns, we'll have reported
= return () -- that already, and we don't want an error cascade
| otherwise
= addErr (vcat [ptext (sLit "Ambiguous occurrence") <+> quotes (ppr rdr_name),
ptext (sLit "It could refer to") <+> vcat (msg1 : msgs)])
where
(np1:nps) = names
(np1:nps) = gres
msg1 = ptext (sLit "either") <+> mk_ref np1
msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps]
mk_ref gre = sep [quotes (ppr (gre_name gre)) <> comma, pprNameProvenance gre]
......
......@@ -414,10 +414,11 @@ extendGlobalRdrEnvRn avails new_fixities
rdr_env3 = foldl extendGlobalRdrEnv rdr_env2 gres
fix_env' = foldl extend_fix_env fix_env gres
(rdr_env', dups) = findLocalDupsRdrEnv rdr_env3 new_occs
dups = findLocalDupsRdrEnv rdr_env3 new_occs
gbl_env' = gbl_env { tcg_rdr_env = rdr_env', tcg_fix_env = fix_env' }
gbl_env' = gbl_env { tcg_rdr_env = rdr_env3, tcg_fix_env = fix_env' }
; traceRn (text "extendGlobalRdrEnvRn dups" <+> (ppr dups))
; mapM_ addDupDeclErr dups
; traceRn (text "extendGlobalRdrEnvRn" <+> (ppr new_fixities $$ ppr fix_env $$ ppr fix_env'))
......
......@@ -548,15 +548,19 @@ mkExport :: PragFun
mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
= do { mono_ty <- zonkTcType (idType mono_id)
; let inferred_poly_ty = mkSigmaTy my_tvs theta mono_ty
my_tvs = filter (`elemVarSet` used_tvs) qtvs
used_tvs = tyVarsOfTypes theta `unionVarSet` tyVarsOfType mono_ty
poly_id = case mb_sig of
; let poly_id = case mb_sig of
Nothing -> mkLocalId poly_name inferred_poly_ty
Just sig -> sig_id sig
-- poly_id has a zonked type
-- In the inference case (no signature) this stuff figures out
-- the right type variables and theta to quantify over
-- See Note [Impedence matching]
my_tv_set = growThetaTyVars theta (tyVarsOfType mono_ty)
my_tvs = filter (`elemVarSet` my_tv_set) qtvs -- Maintain original order
my_theta = filter (quantifyPred my_tv_set) theta
inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty
; poly_id <- addInlinePrags poly_id prag_sigs
; spec_prags <- tcSpecPrags poly_id prag_sigs
-- tcPrags requires a zonked poly_id
......@@ -571,6 +575,7 @@ mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
-- Remember we are in the tcPolyInfer case, so the type envt is
-- closed (unless we are doing NoMonoLocalBinds in which case all bets
-- are off)
-- See Note [Impedence matching]
; (wrap, wanted) <- addErrCtxtM (mk_msg poly_id) $
captureConstraints $
tcSubType origin sig_ctxt sel_poly_ty (idType poly_id)
......@@ -599,8 +604,48 @@ mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
prag_sigs = prag_fn poly_name
origin = AmbigOrigin poly_name
sig_ctxt = InfSigCtxt poly_name
\end{code}
------------------------
Note [Impedence matching]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f 0 x = x
f n x = g [] (not x)
g [] y = f 10 y
g _ y = f 9 y
After typechecking we'll get
f_mono_ty :: a -> Bool -> Bool
g_mono_ty :: [b] -> Bool -> Bool
with constraints
(Eq a, Num a)
Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
The types we really want for f and g are
f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
g :: forall b. [b] -> Bool -> Bool
We can get these by "impedence matching":
tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
Suppose the shared quantified tyvars are qtvs and constraints theta.
Then we want to check that
f's polytype is more polymorphic than forall qtvs. theta => f_mono_ty
and the proof is the impedence matcher.
Notice that the impedence matcher may do defaulting. See Trac #7173.
It also cleverly does an ambiguity check; for example, rejecting
f :: F a -> a
where F is a non-injective type function.
\begin{code}
type PragFun = Name -> [LSig Name]
mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
......
......@@ -174,7 +174,7 @@ canonicalize :: Ct -> TcS StopOrContinue
canonicalize ct@(CNonCanonical { cc_ev = fl, cc_depth = d })
= do { traceTcS "canonicalize (non-canonical)" (ppr ct)
; {-# SCC "canEvVar" #-}
canEvVar d fl (classifyPredType (ctPred ct)) }
canEvVar d fl }
canonicalize (CDictCan { cc_depth = d
, cc_ev = fl
......@@ -205,11 +205,10 @@ canonicalize (CIrredEvCan { cc_ev = fl
canEvVar :: SubGoalDepth
-> CtEvidence
-> PredTree
-> TcS StopOrContinue
-- Called only for non-canonical EvVars
canEvVar d fl pred_classifier
= case pred_classifier of
canEvVar d fl
= case classifyPredType (ctEvPred fl) of
ClassPred cls tys -> canClassNC d fl cls tys
EqPred ty1 ty2 -> canEqNC d fl ty1 ty2
IrredPred ev_ty -> canIrred d fl ev_ty
......@@ -234,7 +233,7 @@ canTuple d fl tys
; mapM_ add_to_work ctevs
; return Stop }
where
add_to_work fl = addToWork $ canEvVar d fl (classifyPredType (ctEvPred fl))
add_to_work fl = addToWork $ canEvVar d fl
\end{code}
......@@ -425,9 +424,8 @@ canIrred d fl ty
-> continueWith $
CIrredEvCan { cc_ev = new_fl, cc_ty = xi, cc_depth = d }
| otherwise
-> canEvVar d new_fl (classifyPredType (ctEvPred new_fl))
-> canEvVar d new_fl
Nothing -> return Stop }
\end{code}
%************************************************************************
......
......@@ -36,7 +36,7 @@ import Var
import PprCore () -- Instance OutputableBndr TyVar
import TypeRep -- Knows type representation
import TcType
import Type( tyConAppArgN, getEqPredTys_maybe, tyConAppTyCon_maybe, getEqPredTys )
import Type( tyConAppArgN, tyConAppTyCon_maybe, getEqPredTys )
import TysPrim( funTyCon )
import TyCon
import PrelNames
......@@ -114,7 +114,7 @@ isEqVar v = case tyConAppTyCon_maybe (varType v) of
isTcReflCo_maybe :: TcCoercion -> Maybe TcType
isTcReflCo_maybe (TcRefl ty) = Just ty
isTcReflCo_maybe _ = Nothing
isTcReflCo_maybe _ = Nothing
isTcReflCo :: TcCoercion -> Bool
isTcReflCo (TcRefl {}) = True
......@@ -185,13 +185,12 @@ mkTcInstCos co tys = foldl TcInstCo co tys
mkTcCoVarCo :: EqVar -> TcCoercion
-- ipv :: s ~ t (the boxed equality type)
mkTcCoVarCo ipv
| ty1 `eqType` ty2 = TcRefl ty1
| otherwise = TcCoVarCo ipv
where
(ty1, ty2) = case getEqPredTys_maybe (varType ipv) of
Nothing -> pprPanic "mkCoVarLCo" (ppr ipv)
Just tys -> tys
mkTcCoVarCo ipv = TcCoVarCo ipv
-- Previously I checked for (ty ~ ty) and generated Refl,
-- but in fact ipv may not even (visibly) have a (t1 ~ t2) type, because
-- the constraint solver does not substitute in the types of
-- evidence variables as it goes. In any case, the optimisation
-- will be done in the later zonking phase
\end{code}
\begin{code}
......@@ -245,11 +244,9 @@ coVarsOfTcCo tc_co
go (TcLetCo {}) = emptyVarSet -- Harumph. This does legitimately happen in the call
-- to evVarsOfTerm in the DEBUG check of setEvBind
-- We expect only coercion bindings
-- We expect only coercion bindings, so use evTermCoercion
go_bind :: EvBind -> VarSet
go_bind (EvBind _ (EvCoercion co)) = go co
go_bind (EvBind _ (EvId v)) = unitVarSet v
go_bind other = pprPanic "coVarsOfTcCo:Bind" (ppr other)
go_bind (EvBind _ tm) = go (evTermCoercion tm)
get_bndrs :: Bag EvBind -> VarSet
get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet
......
......@@ -55,7 +55,7 @@ module TcMType (
checkValidInstHead, checkValidInstance, validDerivPred,
checkInstTermination, checkValidFamInst, checkTyFamFreeness,
arityErr,
growPredTyVars, growThetaTyVars,
growThetaTyVars, quantifyPred,
--------------------------------
-- Zonking
......@@ -1408,7 +1408,38 @@ Note [Growing the tau-tvs using constraints]
E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}
Then grow precs tvs = {a,b,c}
Note [Inheriting implicit parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this:
f x = (x::Int) + ?y
where f is *not* a top-level binding.
From the RHS of f we'll get the constraint (?y::Int).
There are two types we might infer for f:
f :: Int -> Int
(so we get ?y from the context of f's definition), or
f :: (?y::Int) => Int -> Int
At first you might think the first was better, becuase then
?y behaves like a free variable of the definition, rather than
having to be passed at each call site. But of course, the WHOLE
IDEA is that ?y should be passed at each call site (that's what
dynamic binding means) so we'd better infer the second.
BOTTOM LINE: when *inferring types* you *must* quantify
over implicit parameters. See the predicate isFreeWhenInferring.
\begin{code}
quantifyPred :: TyVarSet -- Quantifying over these
-> PredType -> Bool -- True <=> quantify over this wanted
quantifyPred qtvs pred
| isIPPred pred = True -- Note [Inheriting implicit parameters]
| otherwise = tyVarsOfType pred `intersectsVarSet` qtvs
growThetaTyVars :: TcThetaType -> TyVarSet -> TyVarSet
-- See Note [Growing the tau-tvs using constraints]
growThetaTyVars theta tvs
......@@ -1422,6 +1453,7 @@ growPredTyVars :: TcPredType
-> TyVarSet -- The set to extend
-> TyVarSet -- TyVars of the predicate if it intersects the set,
growPredTyVars pred tvs
| isIPPred pred = pred_tvs -- Always quantify over implicit parameers
| pred_tvs `intersectsVarSet` tvs = pred_tvs
| otherwise = emptyVarSet
where
......
......@@ -148,7 +148,9 @@ More details in Note [DefaultTyVar].
simplifyAmbiguityCheck :: Name -> WantedConstraints -> TcM (Bag EvBind)
simplifyAmbiguityCheck name wanteds
= traceTc "simplifyAmbiguityCheck" (text "name =" <+> ppr name) >>
simplifyCheck wanteds
simplifyTop wanteds -- NB: must be simplifyTop not simplifyCheck, so that we
-- do ambiguity resolution.
-- See Note [Impedence matching] in TcBinds.
------------------
simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
......@@ -404,7 +406,7 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs
poly_qtvs = growThetaTyVars final_quant_candidates init_tvs
`minusVarSet` gbl_tvs
pbound = filter (quantifyMe poly_qtvs id) final_quant_candidates
pbound = filter (quantifyPred poly_qtvs) final_quant_candidates
; traceTc "simplifyWithApprox" $
vcat [ ptext (sLit "pbound =") <+> ppr pbound
......@@ -469,8 +471,8 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
\end{code}
Note [Note [Default while Inferring]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [Default while Inferring]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Our current plan is that defaulting only happens at simplifyTop and
not simplifyInfer. This may lead to some insoluble deferred constraints
Example:
......@@ -538,16 +540,6 @@ approximateWC wc = float_wc emptyVarSet wc
do_bag :: (a -> Bag c) -> Bag a -> Bag c
do_bag f = foldrBag (unionBags.f) emptyBag
quantifyMe :: TyVarSet -- Quantifying over these
-> (a -> PredType)
-> a -> Bool -- True <=> quantify over this wanted
quantifyMe qtvs toPred ct
| isIPPred pred = True -- Note [Inheriting implicit parameters]
| otherwise = tyVarsOfType pred `intersectsVarSet` qtvs
where
pred = toPred ct
\end{code}
Note [Avoid unecessary constraint simplification]
......@@ -574,32 +566,6 @@ the contraints before simplifying.
This only half-works, but then let-generalisation only half-works.
Note [Inheriting implicit parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this:
f x = (x::Int) + ?y
where f is *not* a top-level binding.
From the RHS of f we'll get the constraint (?y::Int).
There are two types we might infer for f:
f :: Int -> Int
(so we get ?y from the context of f's definition), or
f :: (?y::Int) => Int -> Int
At first you might think the first was better, becuase then
?y behaves like a free variable of the definition, rather than
having to be passed at each call site. But of course, the WHOLE
IDEA is that ?y should be passed at each call site (that's what
dynamic binding means) so we'd better infer the second.
BOTTOM LINE: when *inferring types* you *must* quantify
over implicit parameters. See the predicate isFreeWhenInferring.
*********************************************************************************
* *
* RULES *
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment