summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
bcfdbbe)
* Fix long-standing bug in TcIfaceSig which meant it occasionally complained
about a lint error in an unfolding, with a locally-defined name not
being in scope. This only happened when hi-boot loops were being
tied, so an unfolding might mention a locally-defined name.
tcLookupValue, tcLookupValueMaybe,
tcLookupValueByKey, tcLookupValueByKeyMaybe,
explicitLookupValueByKey, explicitLookupValue,
tcLookupValue, tcLookupValueMaybe,
tcLookupValueByKey, tcLookupValueByKeyMaybe,
explicitLookupValueByKey, explicitLookupValue,
newLocalId, newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars,
newLocalId, newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars,
type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing)
type ValueEnv = NameEnv Id
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
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
import TcEnv ( ValueEnv, tcExtendTyVarEnv,
tcExtendGlobalValEnv, tcSetValueEnv,
tcLookupTyConByKey, tcLookupValueMaybe,
import TcEnv ( ValueEnv, tcExtendTyVarEnv,
tcExtendGlobalValEnv, tcSetValueEnv,
tcLookupTyConByKey, tcLookupValueMaybe,
- explicitLookupValue, badCon, badPrimOp
+ explicitLookupValue, badCon, badPrimOp, valueEnvIds
)
import TcType ( TcKind, kindToTcKind )
)
import TcType ( TcKind, kindToTcKind )
import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, unUsgTy )
import Var ( IdOrTyVar, mkTyVar, tyVarKind )
import VarEnv
import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, unUsgTy )
import Var ( IdOrTyVar, mkTyVar, tyVarKind )
import VarEnv
-import Name ( Name, NamedThing(..) )
+import Name ( Name, NamedThing(..), isLocallyDefined )
import Unique ( rationalTyConKey )
import TysWiredIn ( integerTy, stringTy )
import Demand ( wwLazy )
import Unique ( rationalTyConKey )
import TysWiredIn ( integerTy, stringTy )
import Demand ( wwLazy )
-tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
- = tcAddSrcLoc src_loc (
- tcAddErrCtxt (ifaceSigCtxt name) (
- tcHsType ty `thenTc` \ sigma_ty ->
- tcIdInfo unf_env name sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info ->
+tcInterfaceSigs unf_env decls
+ = listTc [ do_one name ty id_infos src_loc
+ | SigD (IfaceSig name ty id_infos src_loc) <- decls]
+ where
+ in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
+
+ do_one name ty id_infos src_loc
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (ifaceSigCtxt name) $
+ tcHsType ty `thenTc` \ sigma_ty ->
+ tcIdInfo unf_env in_scope_vars name
+ sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info ->
returnTc (mkId name sigma_ty id_info)
returnTc (mkId name sigma_ty id_info)
- )) `thenTc` \ sig_id ->
- tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
- returnTc (sig_id : sig_ids)
-
-tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
-
-tcInterfaceSigs unf_env [] = returnTc []
-tcIdInfo unf_env name ty info info_ins
+tcIdInfo unf_env in_scope_vars name ty info info_ins
= foldlTc tcPrag vanillaIdInfo info_ins
where
tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
= foldlTc tcPrag vanillaIdInfo info_ins
where
tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
tcPrag info (HsUnfold inline_prag maybe_expr)
= (case maybe_expr of
tcPrag info (HsUnfold inline_prag maybe_expr)
= (case maybe_expr of
- Just expr -> tcPragExpr unf_env name [] expr
+ Just expr -> tcPragExpr unf_env name in_scope_vars expr
Nothing -> returnNF_Tc Nothing
) `thenNF_Tc` \ maybe_expr' ->
let
Nothing -> returnNF_Tc Nothing
) `thenNF_Tc` \ maybe_expr' ->
let
import TcMonad
import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars,
tcExtendUVarEnv, tcLookupUVar,
import TcMonad
import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars,
tcExtendUVarEnv, tcLookupUVar,
- tcGetGlobalTyVars, TcTyThing(..)
+ tcGetGlobalTyVars, valueEnvIds, TcTyThing(..)
)
import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
typeToTcType, kindToTcKind,
)
import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
typeToTcType, kindToTcKind,
import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy )
import SrcLoc ( SrcLoc )
import Unique ( Unique, Uniquable(..) )
import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy )
import SrcLoc ( SrcLoc )
import Unique ( Unique, Uniquable(..) )
-import UniqFM ( eltsUFM )
import Util ( zipWithEqual, zipLazy, mapAccumL )
import Outputable
\end{code}
import Util ( zipWithEqual, zipLazy, mapAccumL )
import Outputable
\end{code}
if tv `elemVarSet` globals -- Error (c)! Type variable escapes
-- The least comprehensible, so put it last
then tcGetValueEnv `thenNF_Tc` \ ve ->
if tv `elemVarSet` globals -- Error (c)! Type variable escapes
-- The least comprehensible, so put it last
then tcGetValueEnv `thenNF_Tc` \ ve ->
- find_globals tv env (eltsUFM ve) `thenNF_Tc` \ (env1, globs) ->
+ find_globals tv env (valueEnvIds ve) `thenNF_Tc` \ (env1, globs) ->
returnNF_Tc (env1, acc, escape_msg sig_tyvar tv globs : msgs)
else -- All OK
returnNF_Tc (env1, acc, escape_msg sig_tyvar tv globs : msgs)
else -- All OK