TcEnv, ValueEnv, TcTyThing(..),
- initEnv, getEnvTyCons, getEnvClasses,
+ initEnv, getEnvTyCons, getEnvClasses, getAllEnvTyCons,
+ tcExtendUVarEnv, tcLookupUVar,
+
tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
tcLookupTy,
tcLookupValue, tcLookupValueMaybe,
tcLookupValueByKey, tcLookupValueByKeyMaybe,
explicitLookupValueByKey, explicitLookupValue,
+ valueEnvIds,
newLocalId, newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars,
import Id ( mkUserLocal, isDataConId_maybe )
import MkId ( mkSpecPragmaId )
import Var ( TyVar, Id, setVarName,
- idType, setIdInfo, idInfo, tyVarKind
+ idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
)
import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
tcInstTyVars, zonkTcTyVars,
import VarEnv
import VarSet
import Type ( Kind, superKind,
- tyVarsOfType, tyVarsOfTypes, mkTyVarTy, substTy,
- splitForAllTys, splitRhoTy, splitFunTys, substTopTy,
+ tyVarsOfType, tyVarsOfTypes, mkTyVarTy,
+ splitForAllTys, splitRhoTy, splitFunTys,
splitAlgTyConApp_maybe, getTyVar
)
+import Subst ( substTy )
+import UsageSPUtils ( unannotTy )
import DataCon ( DataCon )
import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
-import Class ( Class )
+import Class ( Class, classTyCon )
import TcMonad
import BasicTypes ( Arity )
-import IdInfo ( noIdInfo )
+import IdInfo ( vanillaIdInfo )
import Name ( Name, OccName, nameOccName, getSrcLoc,
maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
NamedThing(..)
import Unique ( Uniquable(..) )
import Util ( zipEqual, zipWith3Equal, mapAccumL )
import Bag ( bagToList )
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, catMaybes )
import SrcLoc ( SrcLoc )
import FastString ( FastString )
import Outputable
TcType) --
tcInstId id
= let
- (tyvars, rho) = splitForAllTys (idType id)
+ (tyvars, rho) = splitForAllTys (unannotTy (idType id))
in
tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
let
- rho' = substTopTy tenv rho
+ rho' = substTy tenv rho
(theta', tau') = splitRhoTy rho'
in
returnNF_Tc (tyvars', theta', tau')
\end{code}
+Between the renamer and the first invocation of the UsageSP inference,
+identifiers read from interface files will have usage information in
+their types, whereas other identifiers will not. The unannotTy here
+in @tcInstId@ prevents this information from pointlessly propagating
+further prior to the first usage inference.
+
%************************************************************************
%* *
\begin{code}
data TcEnv = TcEnv
+ UsageEnv
TypeEnv
ValueEnv
(TcTyVarSet, -- The in-scope TyVars
type NameEnv val = UniqFM val -- Keyed by Names
+type UsageEnv = NameEnv UVar
type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing)
type ValueEnv = NameEnv Id
+valueEnvIds :: ValueEnv -> [Id]
+valueEnvIds ve = eltsUFM ve
+
data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
-- if the kind is mutable, the tyvar must be so that
-- zonking works
initEnv :: TcRef TcTyVarSet -> TcEnv
-initEnv mut = TcEnv emptyUFM emptyUFM (emptyVarSet, mut)
+initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM (emptyVarSet, mut)
+
+getEnvTyCons (TcEnv _ te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
+getEnvClasses (TcEnv _ te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
+getAllEnvTyCons (TcEnv _ te _ _) = catMaybes (map gettc (eltsUFM te))
+ where
+ gettc (_,_, ATyCon tc) = Just tc
+ gettc (_,_, AClass cl) = Just (classTyCon cl)
+ gettc _ = Nothing
+\end{code}
+
+The UsageEnv
+~~~~~~~~~~~~
+
+Extending the usage environment.
-getEnvTyCons (TcEnv te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
-getEnvClasses (TcEnv te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
+\begin{code}
+tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
+tcExtendUVarEnv uv_name uv scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
+ tcSetEnv (TcEnv (addToUFM ue uv_name uv) te ve gtvs) scope
\end{code}
+Looking up in the environments.
+
+\begin{code}
+tcLookupUVar :: Name -> NF_TcM s UVar
+tcLookupUVar uv_name
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
+ case lookupUFM ue uv_name of
+ Just uv -> returnNF_Tc uv
+ Nothing -> failWithTc (uvNameOutOfScope uv_name)
+\end{code}
+
+
The TypeEnv
~~~~~~~~~~~~
\begin{code}
tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
tcExtendTyVarEnv tyvars scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) ->
let
extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), Nothing, ATyVar tv))
| tv <- tyvars
-- class and instance decls, when we mustn't generalise the class tyvars
-- when typechecking the methods.
tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
- tcSetEnv (TcEnv te' ve (in_scope_tvs', gtvs')) scope
+ tcSetEnv (TcEnv ue te' ve (in_scope_tvs', gtvs')) scope
-- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
-- the signature tyvars contain the original names
tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
let
te' = addListToUFM te stuff
in
- tcSetEnv (TcEnv te' ve gtvs) thing_inside
+ tcSetEnv (TcEnv ue te' ve gtvs) thing_inside
where
stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), Nothing, ATyVar inst_tv))
| (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
]
tcExtendGlobalTyVars extra_global_tvs scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope,gtvs)) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope,gtvs)) ->
tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
- tcSetEnv (TcEnv te ve (in_scope,gtvs')) scope
+ tcSetEnv (TcEnv ue te ve (in_scope,gtvs')) scope
tc_extend_gtvs gtvs extra_global_tvs
= tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
\begin{code}
tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
tcGetGlobalTyVars
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (_,gtvs)) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (_,gtvs)) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
let
tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
tcGetInScopeTyVars
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) ->
returnNF_Tc (varSetElems in_scope_tvs)
\end{code}
tcExtendTypeEnv bindings scope
= ASSERT( null [tv | (_, (_,_,ATyVar tv)) <- bindings] )
-- Not for tyvars; use tcExtendTyVarEnv
- tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
let
te' = addListToUFM te bindings
in
- tcSetEnv (TcEnv te' ve gtvs) scope
+ tcSetEnv (TcEnv ue te' ve gtvs) scope
\end{code}
\begin{code}
tcLookupTy :: Name -> NF_TcM s (TcKind, Maybe Arity, TcTyThing)
tcLookupTy name
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
case lookupUFM te name of {
Just thing -> returnNF_Tc thing ;
Nothing ->
tcLookupClassByKey :: Unique -> NF_TcM s Class
tcLookupClassByKey key
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
case lookupUFM_Directly te key of
Just (_, _, AClass cl) -> returnNF_Tc cl
other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
tcLookupTyConByKey key
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
case lookupUFM_Directly te key of
Just (_, _, ATyCon tc) -> returnNF_Tc tc
other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
\begin{code}
tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
tcExtendGlobalValEnv ids scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
let
ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
in
- tcSetEnv (TcEnv te ve' gtvs) scope
+ tcSetEnv (TcEnv ue te ve' gtvs) scope
tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
tcExtendLocalValEnv names_w_ids scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs,gtvs)) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs,gtvs)) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
let
ve' = addListToUFM ve names_w_ids
extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
in
tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
- tcSetEnv (TcEnv te ve' (in_scope_tvs,gtvs')) scope
+ tcSetEnv (TcEnv ue te ve' (in_scope_tvs,gtvs')) scope
\end{code}
tcLookupValue name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc id
- Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
returnNF_Tc (lookupWithDefaultUFM ve def name)
where
def = pprPanic "tcLookupValue:" (ppr name)
tcLookupValueMaybe name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc (Just id)
- Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
returnNF_Tc (lookupUFM ve name)
tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
tcLookupValueByKey key
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
returnNF_Tc (explicitLookupValueByKey ve key)
tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
tcLookupValueByKeyMaybe key
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
returnNF_Tc (lookupUFM_Directly ve key)
tcGetValueEnv :: NF_TcM s ValueEnv
tcGetValueEnv
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
returnNF_Tc ve
tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
tcSetValueEnv ve scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv te _ gtvs) ->
- tcSetEnv (TcEnv te ve gtvs) scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ gtvs) ->
+ tcSetEnv (TcEnv ue te ve gtvs) scope
-- Non-monadic version, environment given explicitly
explicitLookupValueByKey :: ValueEnv -> Unique -> Id
-- have explicit local definitions, so we get a black hole!
= id
| otherwise
- = id `setIdInfo` new_info
+ = id `lazySetIdInfo` new_info
-- The Id must be returned without a data dependency on maybe_id
where
new_info = -- pprTrace "tcAdd" (ppr id) $
case explicitLookupValue unf_env (getName id) of
- Nothing -> noIdInfo
+ Nothing -> vanillaIdInfo
Just imported_id -> idInfo imported_id
-- ToDo: could check that types are the same
\end{code}
badPrimOp op
= quotes (ppr op) <+> ptext SLIT("is not a primop")
+uvNameOutOfScope name
+ = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")
+
tyNameOutOfScope name
= quotes (ppr name) <+> ptext SLIT("is not in scope")
\end{code}
projects / ghc-hetmet.git / blobdiff