Commit cc1cc09d authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 0440d8af 336a7698
......@@ -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
......
......@@ -1782,10 +1782,9 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn,
-- level. Reason: so that when we read it back in we'll
-- construct the same ru_rough field as we have right now;
-- see tcIfaceRule
do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
do_arg (Coercion co) = IfaceType (coToIfaceType co)
do_arg arg = toIfaceExpr arg
do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
do_arg (Coercion co) = IfaceCo (coToIfaceType co)
do_arg arg = toIfaceExpr arg
-- Compute orphanhood. See Note [Orphans] in IfaceSyn
-- A rule is an orphan only if none of the variables
......
......@@ -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
......
......@@ -320,15 +320,15 @@ iselExpr64 (CmmLit (CmmInt i _)) = do
(rlo,rhi) <- getNewRegPairNat II32
let
half0 = fromIntegral (fromIntegral i :: Word16)
half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16)
half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16)
half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16)
half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)
half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)
code = toOL [
LIS rlo (ImmInt half1),
OR rlo rlo (RIImm $ ImmInt half0),
LIS rhi (ImmInt half3),
OR rlo rlo (RIImm $ ImmInt half2)
OR rhi rhi (RIImm $ ImmInt half2)
]
return (ChildCode64 code rlo)
......
......@@ -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'))
......
......@@ -725,8 +725,13 @@ match_co :: RuleEnv
-> Maybe RuleSubst
match_co renv subst (CoVarCo cv) co
= match_var renv subst cv (Coercion co)
match_co renv subst (Refl ty1) co
= case co of
Refl ty2 -> match_ty renv subst ty1 ty2
_ -> Nothing
match_co _ _ co1 _
= pprTrace "match_co bailing out" (ppr co1) Nothing
= pprTrace "match_co: needs more cases" (ppr co1) Nothing
-- Currently just deals with CoVarCo and Refl
-------------
rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
......
......@@ -1585,9 +1585,6 @@ argToPat :: ScEnv
argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
= return (False, arg)
argToPat _env _in_scope _val_env arg@(Coercion {}) _arg_occ
= return (False, arg)
argToPat env in_scope val_env (Tick _ arg) arg_occ
= argToPat env in_scope val_env arg arg_occ
-- Note [Notes in call patterns]
......@@ -1696,6 +1693,7 @@ argToPat env in_scope val_env (Var v) arg_occ
-- We don't want to specialise for that *particular* x,y
-- The default case: make a wild-card
-- We use this for coercions too
argToPat _env _in_scope _val_env arg _arg_occ
= wildCardPat (exprType arg)
......@@ -1703,7 +1701,7 @@ wildCardPat :: Type -> UniqSM (Bool, CoreArg)
wildCardPat ty
= do { uniq <- getUniqueUs
; let id = mkSysLocal (fsLit "sc") uniq ty
; return (False, Var id) }
; return (False, varToCoreExpr id) }
argsToPats :: ScEnv -> InScopeSet -> ValueEnv
-> [CoreArg] -> [ArgOcc] -- Should be same length
......
......@@ -1573,10 +1573,7 @@ mkCallUDs :: Id -> [CoreExpr] -> UsageDetails
mkCallUDs f args
| not (want_calls_for f) -- Imported from elsewhere
|| null theta -- Not overloaded
|| not (all isClassPred theta)
-- Only specialise if all overloading is on class params.
-- In ptic, with implicit params, the type args
-- *don't* say what the value of the implicit param is!
|| not (all type_determines_value theta)
|| not (spec_tys `lengthIs` n_tyvars)
|| not ( dicts `lengthIs` n_dicts)
|| not (any interestingDict dicts) -- Note [Interesting dictionary arguments]
......@@ -1603,6 +1600,13 @@ mkCallUDs f args
| otherwise = Nothing
want_calls_for f = isLocalId f || isInlinablePragma (idInlinePragma f)
type_determines_value pred = isClassPred pred && not (isIPPred pred)
-- Only specialise if all overloading is on non-IP *class* params,
-- because these are the ones whose *type* determines their *value*.
-- In ptic, with implicit params, the type args
-- *don't* say what the value of the implicit param is!
-- See Trac #7101
\end{code}
Note [Interesting dictionary arguments]
......
......@@ -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}