Commit b52f0a40 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

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

Conflicts:
	compiler/types/TyCon.lhs
parents a4b3fda5 1e00b774
......@@ -53,6 +53,7 @@ module DataCon (
import Type
import TypeRep( Type(..) ) -- Used in promoteType
import PrelNames( liftedTypeKindTyConKey )
import Kind
import Unify
import Coercion
......@@ -983,7 +984,7 @@ These two 'buildPromoted..' functions are here because
\begin{code}
buildPromotedTyCon :: TyCon -> TyCon
buildPromotedTyCon tc
= mkPromotedTyCon tc tySuperKind
= mkPromotedTyCon tc (promoteKind (tyConKind tc))
buildPromotedDataCon :: DataCon -> TyCon
buildPromotedDataCon dc
......@@ -1040,7 +1041,7 @@ promoteType ty
= mkForAllTys kvs (go rho)
where
(tvs, rho) = splitForAllTys ty
kvs = [ mkKindVar (tyVarName tv) tySuperKind | tv <- tvs ]
kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
env = zipVarEnv tvs kvs
go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys)
......@@ -1048,4 +1049,12 @@ promoteType ty
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
= TyVarTy kv
go _ = panic "promoteType" -- Argument did not satisfy isPromotableType
promoteKind :: Kind -> SuperKind
-- Promote the kind of a type constructor
-- from (* -> * -> *) to (BOX -> BOX -> BOX)
promoteKind (TyConApp tc [])
| tc `hasKey` liftedTypeKindTyConKey = superKind
promoteKind (FunTy arg res) = FunTy (promoteKind arg) (promoteKind res)
promoteKind k = pprPanic "promoteKind" (ppr k)
\end{code}
......@@ -329,7 +329,7 @@ setTcTyVarDetails tv details = tv { tc_tv_details = details }
mkKindVar :: Name -> SuperKind -> KindVar
-- mkKindVar take a SuperKind as argument because we don't have access
-- to tySuperKind here.
-- to superKind here.
mkKindVar name kind = TyVar
{ varName = name
, realUnique = getKeyFastInt (nameUnique name)
......
......@@ -416,7 +416,7 @@ varTypeTcTyVars :: Var -> TyVarSet
-- Find the type variables free in the type of the variable
-- Remember, coercion variables can mention type variables...
varTypeTcTyVars var
| isLocalId var = tcTyVarsOfType (idType var)
| isLocalId var = tyVarsOfType (idType var)
| otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
idFreeVars :: Id -> VarSet
......
This diff is collapsed.
......@@ -732,7 +732,7 @@ dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
-- This is the crucial function that moves
-- from LCoercions to Coercions; see Note [TcCoercions] in Coercion
-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
-- e.g. dsTcCoercion (trans g1 g2) k
-- = case g1 of EqBox g1# ->
-- case g2 of EqBox g2# ->
......
......@@ -473,7 +473,7 @@ ppr_expr (ExplicitList _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (ExplicitPArr _ exprs)
= pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
= paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (RecordCon con_id _ rbinds)
= hang (ppr con_id) 2 (ppr rbinds)
......@@ -489,7 +489,7 @@ ppr_expr (ExprWithTySigOut expr sig)
4 (ppr sig)
ppr_expr (ArithSeq _ info) = brackets (ppr info)
ppr_expr (PArrSeq _ info) = pa_brackets (ppr info)
ppr_expr (PArrSeq _ info) = paBrackets (ppr info)
ppr_expr EWildPat = char '_'
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
......@@ -554,11 +554,6 @@ pprCmdArg (HsCmdTop cmd _ _ _)
instance OutputableBndr id => Outputable (HsCmdTop id) where
ppr = pprCmdArg
-- add parallel array brackets around a document
--
pa_brackets :: SDoc -> SDoc
pa_brackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\end{code}
HsSyn records exactly where the user put parens, with HsPar.
......@@ -1132,7 +1127,7 @@ pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts
pprDo ListComp stmts = brackets $ pprComp stmts
pprDo PArrComp stmts = pa_brackets $ pprComp stmts
pprDo PArrComp stmts = paBrackets $ pprComp stmts
pprDo MonadComp stmts = brackets $ pprComp stmts
pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
......
......@@ -246,7 +246,7 @@ pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat]
pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
pprPat (ParPat pat) = parens (ppr pat)
pprPat (ListPat pats _) = brackets (interpp'SP pats)
pprPat (PArrPat pats _) = pabrackets (interpp'SP pats)
pprPat (PArrPat pats _) = paBrackets (interpp'SP pats)
pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
pprPat (ConPatIn con details) = pprUserCon con details
......@@ -292,11 +292,6 @@ instance (OutputableBndr id, Outputable arg)
ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
hsRecPun = pun })
= ppr f <+> (ppUnless pun $ equals <+> ppr arg)
-- add parallel array brackets around a document
--
pabrackets :: SDoc -> SDoc
pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\end{code}
......
......@@ -560,7 +560,7 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
_ -> BoxedTuple
ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind)
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
......@@ -613,10 +613,6 @@ ppr_fun_ty ctxt_prec ty1 ty2
in
maybeParen ctxt_prec pREC_FUN $
sep [p1, ptext (sLit "->") <+> p2]
--------------------------
pabrackets :: SDoc -> SDoc
pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\end{code}
......@@ -123,7 +123,7 @@ ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName
ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName
ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName
ifaceTyConName IfaceConstraintKindTc = constraintKindTyConName
ifaceTyConName IfaceSuperKindTc = tySuperKindTyConName
ifaceTyConName IfaceSuperKindTc = superKindTyConName
ifaceTyConName (IfaceTc ext) = ext
ifaceTyConName (IfaceIPTc n) = pprPanic "ifaceTyConName:IPTc" (ppr n)
-- Note [The Name of an IfaceAnyTc]
......@@ -283,7 +283,7 @@ ppr_tc_app _ tc [] = ppr_tc tc
ppr_tc_app _ IfaceListTc [ty] = brackets (pprIfaceType ty)
ppr_tc_app _ IfaceListTc _ = panic "ppr_tc_app IfaceListTc"
ppr_tc_app _ IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
ppr_tc_app _ IfacePArrTc [ty] = paBrackets (pprIfaceType ty)
ppr_tc_app _ IfacePArrTc _ = panic "ppr_tc_app IfacePArrTc"
ppr_tc_app _ (IfaceTupTc sort _) tys =
......@@ -326,10 +326,6 @@ pprIfaceContext theta = ppr_preds theta <+> darrow
ppr_preds :: [IfacePredType] -> SDoc
ppr_preds [pred] = ppr pred -- No parens
ppr_preds preds = parens (sep (punctuate comma (map ppr preds)))
-------------------
pabrackets :: SDoc -> SDoc
pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\end{code}
%************************************************************************
......@@ -399,7 +395,7 @@ toIfaceWiredInTyCon tc nm
| nm == argTypeKindTyConName = IfaceArgTypeKindTc
| nm == constraintKindTyConName = IfaceConstraintKindTc
| nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc
| nm == tySuperKindTyConName = IfaceSuperKindTc
| nm == superKindTyConName = IfaceSuperKindTc
| otherwise = IfaceTc nm
----------------
......
......@@ -41,7 +41,7 @@ import TyCon
import DataCon
import PrelNames
import TysWiredIn
import TysPrim ( tySuperKindTyCon )
import TysPrim ( superKindTyCon )
import BasicTypes ( Arity, strongLoopBreaker )
import Literal
import qualified Var
......@@ -1304,7 +1304,7 @@ tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon
tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon
tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon
tcIfaceTyCon IfaceConstraintKindTc = return constraintKindTyCon
tcIfaceTyCon IfaceSuperKindTc = return tySuperKindTyCon
tcIfaceTyCon IfaceSuperKindTc = return superKindTyCon
-- Even though we are in an interface file, we want to make
-- sure the instances and RULES of this tycon are loaded
......
......@@ -1255,8 +1255,8 @@ eitherTyConKey :: Unique
eitherTyConKey = mkPreludeTyConUnique 84
-- Super Kinds constructors
tySuperKindTyConKey :: Unique
tySuperKindTyConKey = mkPreludeTyConUnique 85
superKindTyConKey :: Unique
superKindTyConKey = mkPreludeTyConUnique 85
-- Kind constructors
liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey,
......
......@@ -25,11 +25,11 @@ module TysPrim(
kKiVar,
-- Kind constructors...
tySuperKindTyCon, tySuperKind, anyKindTyCon,
superKindTyCon, superKind, anyKindTyCon,
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon,
tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
superKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
openTypeKindTyConName, unliftedTypeKindTyConName,
ubxTupleKindTyConName, argTypeKindTyConName,
constraintKindTyConName,
......@@ -232,7 +232,7 @@ argAlphaTy = mkTyVarTy argAlphaTyVar
argBetaTy = mkTyVarTy argBetaTyVar
kKiVar :: KindVar
kKiVar = (tyVarList tySuperKind) !! 10
kKiVar = (tyVarList superKind) !! 10
\end{code}
......@@ -281,33 +281,53 @@ funTyCon = mkFunTyCon funTyConName $
%* *
%************************************************************************
Note [SuperKind (BOX)]
~~~~~~~~~~~~~~~~~~~~~~
Kinds are classified by "super-kinds". There is only one super-kind, namely BOX.
Perhaps surprisingly we give BOX the kind BOX, thus BOX :: BOX
Reason: we want to have kind equalities, thus (without the kind applications)
keq :: * ~ * = Eq# <refl *>
Remember that
(~) :: forall (k:BOX). k -> k -> Constraint
(~#) :: forall (k:BOX). k -> k -> #
Eq# :: forall (k:BOX). forall (a:k) (b:k). (~#) k a b -> (~) k a b
So the full defn of keq is
keq :: (~) BOX * * = Eq# BOX * * <refl *>
So you can see it's convenient to have BOX:BOX
\begin{code}
-- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
tySuperKindTyCon, anyKindTyCon, liftedTypeKindTyCon,
superKindTyCon, anyKindTyCon, liftedTypeKindTyCon,
openTypeKindTyCon, unliftedTypeKindTyCon,
ubxTupleKindTyCon, argTypeKindTyCon,
constraintKindTyCon
:: TyCon
tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
superKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
openTypeKindTyConName, unliftedTypeKindTyConName,
ubxTupleKindTyConName, argTypeKindTyConName,
constraintKindTyConName
:: Name
tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName
anyKindTyCon = mkKindTyCon anyKindTyConName tySuperKind
liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind
openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind
unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind
argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind
constraintKindTyCon = mkKindTyCon constraintKindTyConName tySuperKind
superKindTyCon = mkKindTyCon superKindTyConName superKind
-- See Note [SuperKind (BOX)]
anyKindTyCon = mkKindTyCon anyKindTyConName superKind
liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName superKind
openTypeKindTyCon = mkKindTyCon openTypeKindTyConName superKind
unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName superKind
ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName superKind
argTypeKindTyCon = mkKindTyCon argTypeKindTyConName superKind
constraintKindTyCon = mkKindTyCon constraintKindTyConName superKind
--------------------------
-- ... and now their names
tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon
superKindTyConName = mkPrimTyConName (fsLit "BOX") superKindTyConKey superKindTyCon
anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon
liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
openTypeKindTyConName = mkPrimTyConName (fsLit "OpenKind") openTypeKindTyConKey openTypeKindTyCon
unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
......@@ -330,10 +350,12 @@ kindTyConType :: TyCon -> Type
kindTyConType kind = TyConApp kind []
-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind, constraintKind,
superKind :: Kind
-- See Note [Any kinds]
anyKind = kindTyConType anyKindTyCon
superKind = kindTyConType superKindTyCon
anyKind = kindTyConType anyKindTyCon -- See Note [Any kinds]
liftedTypeKind = kindTyConType liftedTypeKindTyCon
unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
openTypeKind = kindTyConType openTypeKindTyCon
......@@ -348,9 +370,6 @@ mkArrowKind k1 k2 = FunTy k1 k2
-- | Iterated application of 'mkArrowKind'
mkArrowKinds :: [Kind] -> Kind -> Kind
mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
tySuperKind :: SuperKind
tySuperKind = kindTyConType tySuperKindTyCon
\end{code}
%************************************************************************
......
......@@ -419,7 +419,10 @@ the inner loop.
Things to note
* We can't float a case to top level
* It's worth doing this float even if we don't float
the case outside a value lambda
the case outside a value lambda. Example
case x of {
MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)
If we floated the cases out we could eliminate one of them.
* We only do this with a single-alternative case
Note [Check the output scrutinee for okForSpec]
......
......@@ -1668,6 +1668,22 @@ not want to transform to
in blah
because that builds an unnecessary thunk.
Note [Case elimination: unlifted case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
case a +# b of r -> ...r...
Then we do case-elimination (to make a let) followed by inlining,
to get
.....(a +# b)....
If we have
case indexArray# a i of r -> ...r...
we might like to do the same, and inline the (indexArray# a i).
But indexArray# is not okForSpeculation, so we don't build a let
in rebuildCase (lest it get floated *out*), so the inlining doesn't
happen either.
This really isn't a big deal I think. The let can be
Further notes about case elimination
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1788,6 +1804,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
| otherwise = exprOkForSpeculation scrut
-- The case-binder is alive, but we may be able
-- turn the case into a let, if the expression is ok-for-spec
-- See Note [Case elimination: unlifted case]
ok_for_spec = exprOkForSpeculation scrut
is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect
......
......@@ -371,7 +371,7 @@ tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
; return (binds', mono_ids', NotTopLevel) }
where
tc_mono_info (name, _, mono_id)
= do { mono_ty' <- zonkTcTypeCarefully (idType mono_id)
= do { mono_ty' <- zonkTcType (idType mono_id)
-- Zonk, mainly to expose unboxed types to checkStrictBinds
; let mono_id' = setIdType mono_id mono_ty'
; _specs <- tcSpecPrags mono_id' (prag_fn name)
......@@ -399,7 +399,7 @@ tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_scoped = scope
prag_sigs = prag_fn (idName poly_id)
; (ev_binds, (binds', [mono_info]))
<- checkConstraints skol_info tvs ev_vars $
tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $
tcExtendTyVarEnv2 (scoped `zip` tvs) $
tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
; spec_prags <- tcSpecPrags poly_id prag_sigs
......@@ -471,7 +471,7 @@ mkExport :: PragFun
-- Pre-condition: the qtvs and theta are already zonked
mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
= do { mono_ty <- zonkTcTypeCarefully (idType 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
......
This diff is collapsed.
......@@ -71,6 +71,7 @@ import TypeRep
import Class
import Name
import NameEnv
import VarEnv
import HscTypes
import DynFlags
import SrcLoc
......@@ -286,7 +287,7 @@ tcLookupTyVar :: Name -> TcM TcTyVar
tcLookupTyVar name = do
thing <- tcLookup name
case thing of
ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
ATyVar _ tv -> return tv
_ -> pprPanic "tcLookupTyVar" (ppr name)
tcLookupId :: Name -> TcM Id
......@@ -340,18 +341,36 @@ tcExtendKindEnvTvs bndrs thing_inside
= tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs)
(thing_inside bndrs)
-----------------------
-- Scoped type and kind variables
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
= tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
= tcExtendTyVarEnv2 [(tyVarName tv, tv) | tv <- tvs] thing_inside
tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r
tcExtendTyVarEnv2 binds thing_inside
= tc_extend_local_env [(name, ATyVar name ty) | (name, ty) <- binds] thing_inside
getScopedTyVarBinds :: TcM [(Name, TcType)]
= tc_extend_local_env [(name, ATyVar name tv) | (name, tv) <- binds] $
do { env <- getLclEnv
; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) }
; setLclEnv env' thing_inside }
where
add_tidy_tvs env = foldl add env binds
-- We initialise the "tidy-env", used for tidying types before printing,
-- by building a reverse map from the in-scope type variables to the
-- OccName that the programmer originally used for them
add :: TidyEnv -> (Name, TcTyVar) -> TidyEnv
add (env,subst) (name, tyvar)
= case tidyOccName env (nameOccName name) of
(env', occ') -> (env', extendVarEnv subst tyvar tyvar')
where
tyvar' = setTyVarName tyvar name'
name' = tidyNameOcc name occ'
getScopedTyVarBinds :: TcM [(Name, TcTyVar)]
getScopedTyVarBinds
= do { lcl_env <- getLclEnv
; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
; return [(name, tv) | ATyVar name tv <- nameEnvElts (tcl_env lcl_env)] }
\end{code}
......@@ -398,8 +417,8 @@ tcExtendGhciEnv ids thing_inside
| id <- ids]
thing_inside
where
is_top id | isEmptyVarSet (tcTyVarsOfType (idType id)) = TopLevel
| otherwise = NotTopLevel
is_top id | isEmptyVarSet (tyVarsOfType (idType id)) = TopLevel
| otherwise = NotTopLevel
tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a
......@@ -435,8 +454,8 @@ tc_extend_local_env extra_env thing_inside
emptyVarSet
NotTopLevel -> id_tvs
where
id_tvs = tcTyVarsOfType (idType id)
get_tvs (_, ATyVar _ ty) = tcTyVarsOfType ty -- See Note [Global TyVars]
id_tvs = tyVarsOfType (idType id)
get_tvs (_, ATyVar _ tv) = unitVarSet tv -- See Note [Global TyVars]
get_tvs other = pprPanic "get_tvs" (ppr other)
-- Note [Global TyVars]
......
......@@ -992,20 +992,21 @@ find_thing tidy_env ignore_it (ATcId { tct_id = id })
ppr (getSrcLoc id)))]
; return (tidy_env', Just msg) } }
find_thing tidy_env ignore_it (ATyVar tv ty)
= do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
find_thing tidy_env ignore_it (ATyVar name tv)
= do { ty <- zonkTcTyVar tv
; let (tidy_env1, tidy_ty) = tidyOpenType tidy_env ty
; if ignore_it tidy_ty then
return (tidy_env, Nothing)
else do
{ let -- The name tv is scoped, so we don't need to tidy it
msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr name) <+> eq_stuff
, nest 2 bound_at]
eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
, getOccName tv == getOccName tv' = empty
, getOccName name == getOccName tv' = empty
| otherwise = equals <+> ppr tidy_ty
-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc name)
; return (tidy_env1, Just msg) } }
......
......@@ -468,6 +468,7 @@ data EvTerm
| EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
-- dictionaries, even though the former have no
-- selector Id. We count up from _0_
| EvKindCast EvVar TcCoercion -- See Note [EvKindCast]
deriving( Data.Data, Data.Typeable)
......@@ -475,7 +476,6 @@ data EvTerm
Note [EvKindCast]
~~~~~~~~~~~~~~~~~
EvKindCast g kco is produced when we have a constraint (g : s1 ~ s2)
but the kinds of s1 and s2 (k1 and k2 respectively) don't match but
are rather equal by a coercion. You may think that this coercion will
......@@ -485,8 +485,7 @@ that coercion will be an 'error' term, which we want to evaluate rather
than silently forget about!
The relevant (and only) place where such a coercion is produced in
the simplifier is in emit_kind_constraint in TcCanonical.
the simplifier is in TcCanonical.emitKindConstraint.
Note [EvBinds/EvTerm]
~~~~~~~~~~~~~~~~~~~~~
......
......@@ -199,7 +199,7 @@ tcExpr (ExprWithTySig expr sig_ty) res_ty
-- Remember to extend the lexical type-variable environment
; (gen_fn, expr')
<- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` skol_tvs) $
-- See Note [More instantiated than scoped] in TcBinds
tcMonoExprNC expr res_ty
......@@ -892,7 +892,7 @@ tcInferFun fun
-- Zonk the function type carefully, to expose any polymorphism
-- E.g. (( \(x::forall a. a->a). blah ) e)
-- We can see the rank-2 type of the lambda in time to genrealise e
; fun_ty' <- zonkTcTypeCarefully fun_ty
; fun_ty' <- zonkTcType fun_ty
; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty'
; return (mkLHsWrap wrap fun, rho) }
......
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