Commit 2a74e354 authored by sof's avatar sof

[project @ 1997-07-05 02:33:54 by sof]

parent c3b0261f
......@@ -15,7 +15,7 @@ module TcEnv(
tcExtendGlobalValEnv, tcExtendLocalValEnv,
tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
tcAddImportedIdInfo,
tcAddImportedIdInfo, tcExplicitLookupGlobal,
tcLookupGlobalValueByKeyMaybe,
newMonoIds, newLocalIds, newLocalId,
......@@ -26,8 +26,6 @@ module TcEnv(
IMP_Ubiq()
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(TcMLoop) -- for paranoia checking
#else
import {-# SOURCE #-} TcType
#endif
import HsTypes ( HsTyVar(..) )
......@@ -42,13 +40,13 @@ import TyVar ( unionTyVarSets, emptyTyVarSet, tyVarSetToList, SYN_IE(TyVar) )
import PprType ( GenTyVar )
import Type ( tyVarsOfTypes, splitForAllTy )
import TyCon ( TyCon, tyConKind, synTyConArity, SYN_IE(Arity) )
import Class ( SYN_IE(Class), GenClass, classSig )
import Class ( SYN_IE(Class), GenClass )
import TcMonad
import IdInfo ( noIdInfo )
import Name ( Name, OccName(..), getSrcLoc, occNameString,
maybeWiredInTyConName, maybeWiredInIdName,
maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
NamedThing(..)
)
import Pretty
......@@ -255,7 +253,6 @@ tcLookupLocalValueOK err name
tcLookupGlobalValue :: Name -> NF_TcM s Id
tcLookupGlobalValue name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc id
......@@ -265,7 +262,6 @@ tcLookupGlobalValue name
def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name)
tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)
tcLookupGlobalValueMaybe name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc (Just id)
......@@ -289,18 +285,29 @@ tcLookupGlobalValueByKeyMaybe uniq
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupUFM_Directly gve uniq)
-- Non-monadic version, environment given explicitly
tcExplicitLookupGlobal :: TcEnv s -> Name -> Maybe Id
tcExplicitLookupGlobal (TcEnv tve tce ce gve lve gtvs) name
= case maybeWiredInIdName name of
Just id -> Just id
Nothing -> lookupUFM gve name
-- Extract the IdInfo from an IfaceSig imported from an interface file
tcAddImportedIdInfo :: Id -> NF_TcM s Id
tcAddImportedIdInfo id
= tcLookupGlobalValueMaybe (getName id) `thenNF_Tc` \ maybe_id ->
let
new_info = case maybe_id of
tcAddImportedIdInfo :: TcEnv s -> Id -> Id
tcAddImportedIdInfo unf_env id
| isLocallyDefined id -- Don't look up locally defined Ids, because they
-- have explicit local definitions, so we get a black hole!
= id
| otherwise
= id `replaceIdInfo` new_info
-- The Id must be returned without a data dependency on maybe_id
where
new_info = -- pprTrace "tcAdd" (ppr PprDebug id) $
case tcExplicitLookupGlobal unf_env (getName id) of
Nothing -> noIdInfo
Just imported_id -> getIdInfo imported_id
-- ToDo: could check that types are the same
in
returnNF_Tc (id `replaceIdInfo` new_info)
-- The Id must be returned without a data dependency on maybe_id
\end{code}
......
......@@ -44,7 +44,7 @@ import TcType ( SYN_IE(TcType), TcMaybe(..),
newTyVarTy, newTyVarTys, zonkTcTyVars, zonkTcType )
import TcKind ( TcKind )
import Class ( SYN_IE(Class), classSig )
import Class ( SYN_IE(Class) )
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
import Id ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
isRecordSelector,
......@@ -295,7 +295,7 @@ tcExpr (HsLet binds expr)
where
tc_expr expr = tcExpr expr `thenTc` \ (expr', lie, ty) ->
returnTc ((expr',ty), lie)
combiner bind (expr, ty) = (HsLet bind expr, ty)
combiner is_rec bind (expr, ty) = (HsLet (MonoBind bind [] is_rec) expr, ty)
tcExpr in_expr@(HsCase expr matches src_loc)
= tcAddSrcLoc src_loc $
......@@ -885,7 +885,7 @@ tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
binds
do_next
where
combine' binds' thing' = combine (LetStmt binds') Nothing thing'
combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
\end{code}
%************************************************************************
......
......@@ -76,6 +76,6 @@ tcGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
) `thenTc` \ (grhss_and_binds'@(GRHSsAndBindsOut _ _ result_ty), lie) ->
returnTc (grhss_and_binds', lie, result_ty)
where
combiner binds1 (GRHSsAndBindsOut grhss binds2 ty)
= GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
combiner is_rec binds1 (GRHSsAndBindsOut grhss binds2 ty)
= GRHSsAndBindsOut grhss ((MonoBind binds1 [] is_rec) `ThenBinds` binds2) ty
\end{code}
......@@ -37,6 +37,7 @@ import HsSyn ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
import RdrHsSyn ( RdrName(..), varQual, varUnqual, mkOpApp,
SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
)
import BasicTypes ( IfaceFlavour(..) )
import Id ( GenId, isNullaryDataCon, dataConTag,
dataConRawArgTys, fIRST_TAG,
isDataCon, SYN_IE(DataCon), SYN_IE(ConTag),
......@@ -1051,7 +1052,7 @@ genOpApp e1 op e2 = mkOpApp e1 op e2
\end{code}
\begin{code}
qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n }
qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }
a_RDR = varUnqual SLIT("a")
b_RDR = varUnqual SLIT("b")
......
This diff is collapsed.
......@@ -13,7 +13,8 @@ IMP_Ubiq()
import TcMonad
import TcMonoType ( tcHsType, tcHsTypeKind )
import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv,
tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue
tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue,
tcExplicitLookupGlobal
)
import TcKind ( TcKind, kindToTcKind )
......@@ -21,7 +22,7 @@ import HsSyn ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDe
Fake, InPat, HsType )
import RnHsSyn ( RenamedHsDecl(..) )
import HsCore
import HsDecls ( HsIdInfo(..) )
import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import Literal ( Literal(..) )
import CoreSyn
import CoreUtils ( coreExprType )
......@@ -34,9 +35,9 @@ import PrimOp ( PrimOp(..) )
import Id ( GenId, mkImported, mkUserId, addInlinePragma,
isPrimitiveId_maybe, dataConArgTys, SYN_IE(Id) )
import Type ( mkSynTy, getAppDataTyConExpandingDicts )
import TyVar ( mkTyVar )
import TyVar ( mkSysTyVar )
import Name ( Name )
import Unique ( rationalTyConKey )
import Unique ( rationalTyConKey, uniqueOf )
import TysWiredIn ( integerTy )
import PragmaInfo ( PragmaInfo(..) )
import ErrUtils ( pprBagOfErrors )
......@@ -56,95 +57,91 @@ As always, we do not have to worry about user-pragmas in interface
signatures.
\begin{code}
tcInterfaceSigs :: [RenamedHsDecl] -> TcM s [Id]
-- Ignore non-sig-decls in these decls
tcInterfaceSigs (SigD (IfaceSig name ty id_infos src_loc) : rest)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ifaceSigCtxt name) $
tcHsType ty `thenTc` \ sigma_ty ->
tcIdInfo name sigma_ty noIdInfo id_infos `thenTc` \ id_info' ->
let
imp_id = mkImported name sigma_ty id_info'
sig_id | any inline_please id_infos = addInlinePragma imp_id
| otherwise = imp_id
tcInterfaceSigs :: TcEnv s -- Envt to use when checking unfoldings
-> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
-> TcM s [Id]
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 noIdInfo id_infos `thenTc` \ id_info' ->
let
imp_id = mkImported name sigma_ty id_info'
sig_id | any inline_please id_infos = addInlinePragma imp_id
| otherwise = imp_id
inline_please (HsUnfold inline _) = inline
inline_please other = False
in
tcInterfaceSigs rest `thenTc` \ sig_ids ->
inline_please (HsUnfold inline _) = inline
inline_please other = False
in
returnTc sig_id
)) `thenTc` \ sig_id ->
tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
returnTc (sig_id : sig_ids)
tcInterfaceSigs (other_decl : rest) = tcInterfaceSigs rest
tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
tcInterfaceSigs [] = returnTc []
tcInterfaceSigs unf_env [] = returnTc []
\end{code}
\begin{code}
tcIdInfo name ty info [] = returnTc info
tcIdInfo name ty info (HsArity arity : rest)
= tcIdInfo name ty (info `addArityInfo` arity) rest
tcIdInfo name ty info (HsUpdate upd : rest)
= tcIdInfo name ty (info `addUpdateInfo` upd) rest
tcIdInfo name ty info (HsFBType fb : rest)
= tcIdInfo name ty (info `addFBTypeInfo` fb) rest
tcIdInfo name ty info (HsArgUsage au : rest)
= tcIdInfo name ty (info `addArgUsageInfo` au) rest
tcIdInfo name ty info (HsDeforest df : rest)
= tcIdInfo name ty (info `addDeforestInfo` df) rest
tcIdInfo name ty info (HsUnfold inline expr : rest)
= tcUnfolding name expr `thenNF_Tc` \ unfold_info ->
tcIdInfo name ty (info `addUnfoldInfo` unfold_info) rest
tcIdInfo name ty info (HsStrictness strict : rest)
= tcStrictness ty info strict `thenTc` \ info' ->
tcIdInfo name ty info' rest
tcIdInfo unf_env name ty info info_ins
= go noIdInfo info_ins
where
go info_so_far [] = returnTc info_so_far
go info (HsArity arity : rest) = go (info `addArityInfo` arity) rest
go info (HsUpdate upd : rest) = go (info `addUpdateInfo` upd) rest
go info (HsFBType fb : rest) = go (info `addFBTypeInfo` fb) rest
go info (HsArgUsage au : rest) = go (info `addArgUsageInfo` au) rest
go info (HsDeforest df : rest) = go (info `addDeforestInfo` df) rest
go info (HsUnfold inline expr : rest) = tcUnfolding unf_env name expr `thenNF_Tc` \ unfold_info ->
go (info `addUnfoldInfo` unfold_info) rest
go info (HsStrictness strict : rest) = tcStrictness unf_env ty info strict `thenTc` \ info' ->
go info' rest
\end{code}
\begin{code}
tcStrictness ty info (StrictnessInfo demands maybe_worker)
= tcWorker maybe_worker `thenNF_Tc` \ maybe_worker_id ->
tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker)
= tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id ->
uniqSMToTcM (mkWrapper ty demands) `thenNF_Tc` \ wrap_fn ->
let
-- Watch out! We can't pull on maybe_worker_id too eagerly!
info' = case maybe_worker_id of
Just (worker_id,_) -> info `addUnfoldInfo` mkUnfolding NoPragmaInfo (wrap_fn worker_id)
Nothing -> info
Just worker_id -> info `addUnfoldInfo` mkUnfolding NoPragmaInfo (wrap_fn worker_id)
Nothing -> info
has_worker = maybeToBool maybe_worker_id
in
returnTc (info' `addStrictnessInfo` StrictnessInfo demands maybe_worker_id)
returnTc (info' `addStrictnessInfo` StrictnessInfo demands has_worker)
-- Boring to write these out, but the result type differs from the arg type...
tcStrictness ty info BottomGuaranteed
tcStrictness unf_env ty info HsBottom
= returnTc (info `addStrictnessInfo` BottomGuaranteed)
tcStrictness ty info NoStrictnessInfo
= returnTc info
\end{code}
\begin{code}
tcWorker Nothing = returnNF_Tc Nothing
tcWorker unf_env Nothing = returnNF_Tc Nothing
tcWorker (Just (worker_name,_))
= tcLookupGlobalValueMaybe worker_name `thenNF_Tc` \ maybe_worker_id ->
returnNF_Tc (trace_maybe maybe_worker_id)
tcWorker unf_env (Just (worker_name,_))
= returnNF_Tc (trace_maybe maybe_worker_id)
where
maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name
-- The trace is so we can see what's getting dropped
trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr PprDebug worker_name) Nothing
trace_maybe (Just x) = Just (x, [])
trace_maybe (Just x) = Just x
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
\begin{code}
tcUnfolding name core_expr
tcUnfolding unf_env name core_expr
= forkNF_Tc (
recoverNF_Tc no_unfolding (
tcSetEnv unf_env $
tcCoreExpr core_expr `thenTc` \ core_expr' ->
returnTc (mkUnfolding NoPragmaInfo core_expr')
))
......@@ -261,7 +258,7 @@ tcCoreLamBndr (UfValBinder name ty) thing_inside
tcCoreLamBndr (UfTyBinder name kind) thing_inside
= let
tyvar = mkTyVar name kind
tyvar = mkSysTyVar (uniqueOf name) kind
in
tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
thing_inside (TyBinder tyvar)
......
This diff is collapsed.
......@@ -20,17 +20,15 @@ import HsSyn ( MonoBinds, Fake, InPat, Sig )
import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..),
RenamedInstancePragmas(..) )
import TcEnv ( tcAddImportedIdInfo )
import TcMonad
import Inst ( SYN_IE(InstanceMapper) )
import Bag ( bagToList, Bag )
import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
classBigSig, classOps, classOpLocalType,
SYN_IE(ClassOp), SYN_IE(Class)
import Class ( GenClass, SYN_IE(ClassInstEnv),
classBigSig, SYN_IE(Class)
)
import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal, SYN_IE(Id) )
import Id ( GenId, mkDictFunId, mkSysLocal, SYN_IE(Id) )
import MatchEnv ( nullMEnv, insertMEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc, Name{--O only-} )
......@@ -45,9 +43,7 @@ import TyVar ( GenTyVar, SYN_IE(TyVar) )
import Unique ( Unique )
import Util ( equivClasses, zipWithEqual, panic{-, pprTrace-}, Ord3(..) )
#if __GLASGOW_HASKELL__ >= 202
import Outputable
#endif
\end{code}
instance c => k (t tvs) where b
......@@ -82,13 +78,12 @@ mkInstanceRelatedIds :: Name -- Name to use for the dict fun;
-> [TyVar]
-> Type
-> ThetaType
-> NF_TcM s (Id, ThetaType)
-> (Id, ThetaType)
mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta
= tcAddImportedIdInfo dfun_id `thenNF_Tc` \ new_dfun_id ->
returnNF_Tc (new_dfun_id, dfun_theta)
= (dfun_id, dfun_theta)
where
(_, super_classes, _, _, _, _) = classBigSig clas
(_, super_classes, _, _, _) = classBigSig clas
super_class_theta = super_classes `zip` repeat inst_ty
dfun_theta = case inst_decl_theta of
......@@ -126,24 +121,20 @@ buildInstanceEnvs info
in
mapTc buildInstanceEnv info_by_class `thenTc` \ inst_env_entries ->
let
class_lookup_fn = mkLookupFunDef (==) inst_env_entries
(nullMEnv, \ o -> nullSpecEnv)
class_lookup_fn = mkLookupFunDef (==) inst_env_entries nullMEnv
in
returnTc class_lookup_fn
\end{code}
\begin{code}
buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
-> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
-> TcM s (Class, ClassInstEnv)
buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
= foldlTc addClassInstance
(nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
inst_infos
`thenTc` \ (class_inst_env, op_inst_envs) ->
returnTc (clas, (class_inst_env,
mkLookupFunDef (==) op_inst_envs
(panic "buildInstanceEnv")))
nullMEnv
inst_infos `thenTc` \ class_inst_env ->
returnTc (clas, class_inst_env)
\end{code}
@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
......@@ -152,34 +143,19 @@ about any overlap with an existing instance.
\begin{code}
addClassInstance
:: (ClassInstEnv, [(ClassOp,SpecEnv)])
:: ClassInstEnv
-> InstInfo
-> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
-> TcM s ClassInstEnv
addClassInstance
input_stuff@(class_inst_env, op_spec_envs)
addClassInstance class_inst_env
(InstInfo clas inst_tyvars inst_ty _ _
dfun_id _ src_loc _)
=
-- We only add specialised/overlapped instances
-- if we are specialising the overloading
-- ToDo ... This causes getConstMethodId errors!
--
-- if not (is_plain_instance inst_ty) && not opt_SpecialiseOverloaded
-- then
-- -- Drop this specialised/overlapped instance
-- returnTc (class_inst_env, op_spec_envs)
-- else
-- Add the instance to the class's instance environment
case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
Failed (ty', dfun_id') -> recoverTc (returnTc input_stuff) $
= -- Add the instance to the class's instance environment
case insertMEnv matchTy class_inst_env inst_ty dfun_id of
Failed (ty', dfun_id') -> recoverTc (returnTc class_inst_env) $
dupInstFailure clas (inst_ty, src_loc)
(ty', getSrcLoc dfun_id');
Succeeded class_inst_env' ->
returnTc (class_inst_env', op_spec_envs)
Succeeded class_inst_env' -> returnTc class_inst_env'
{- OLD STUFF FOR CONSTANT METHODS
......@@ -224,7 +200,6 @@ addClassInstance
returnTc (class_inst_env', op_spec_envs')
END OF OLD STUFF -}
}
\end{code}
\begin{code}
......@@ -233,8 +208,8 @@ dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2)
= tcAddErrCtxt ctxt $
failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations"))
where
ctxt sty = hang (sep [ptext SLIT("Class"), ppr sty clas,
ptext SLIT("type"), ppr sty ty1])
4 (sep [hcat [ptext SLIT("at "), ppr sty locn1],
hcat [ptext SLIT("and "), ppr sty locn2]])
ctxt sty = sep [hsep [ptext SLIT("for"),
pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty1],
nest 4 (sep [ptext SLIT("at") <+> ppr sty locn1,
ptext SLIT("and") <+> ppr sty locn2])]
\end{code}
......@@ -24,9 +24,7 @@ import TcMonad
import Unique ( Unique, pprUnique10 )
import Pretty
import Util ( nOfThem )
#if __GLASGOW_HASKELL__ >= 202
import Outputable
#endif
\end{code}
......@@ -179,7 +177,7 @@ zonkTcKind kind@(TcVarKind uniq box)
\begin{code}
instance Outputable (TcKind s) where
ppr sty kind = ppr_kind sty kind
ppr sty kind = pprQuote sty $ \ sty -> ppr_kind sty kind
ppr_kind sty TcTypeKind
= char '*'
......
This diff is collapsed.
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