TcHsModule, TcCoreExpr, TcDictBinds,
TcForeignExportDecl,
- TypecheckedHsBinds,
+ TypecheckedHsBinds, TypecheckedRuleDecl,
TypecheckedMonoBinds, TypecheckedPat,
TypecheckedHsExpr, TypecheckedArithSeqInfo,
TypecheckedStmt, TypecheckedForeignDecl,
TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
- mkHsTyApp, mkHsDictApp,
- mkHsTyLam, mkHsDictLam,
+ mkHsTyApp, mkHsDictApp, mkHsConApp,
+ mkHsTyLam, mkHsDictLam, mkHsLet,
+ idsToMonoBinds,
-- re-exported from TcEnv
TcId, tcInstId,
- maybeBoxedPrimType,
-
zonkTopBinds, zonkId, zonkIdOcc,
- zonkForeignExports
+ zonkForeignExports, zonkRules
) where
#include "HsVersions.h"
import HsSyn -- oodles of it
-- others:
-import Id ( idName, idType, setIdType, omitIfaceSigForId, Id )
-import DataCon ( DataCon, dataConArgTys )
-import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
- ValueEnv, TcId, tcInstId
+import Id ( idName, idType, isLocalId, idUnfolding, setIdType, isIP, Id )
+import DataCon ( dataConWrapId )
+import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
+ TcEnv, TcId, tcInstId
)
import TcMonad
-import TcType ( TcType, TcTyVar,
- zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
+import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
)
-import TyCon ( isDataTyCon )
-import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
-import Name ( isLocallyDefined )
-import Var ( TyVar )
-import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList )
-import VarSet ( isEmptyVarSet )
import CoreSyn ( Expr )
+import CoreUnfold( unfoldingTemplate )
+import BasicTypes ( RecFlag(..) )
import Bag
-import UniqFM
import Outputable
+import HscTypes ( TyThing(..) )
\end{code}
type TcCoreExpr = Expr TcId
type TcForeignExportDecl = ForeignDecl TcId
+type TcRuleDecl = RuleDecl TcId TcPat
type TypecheckedPat = OutPat Id
type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
type TypecheckedHsModule = HsModule Id TypecheckedPat
type TypecheckedForeignDecl = ForeignDecl Id
+type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
\end{code}
\begin{code}
mkHsDictLam [] expr = expr
mkHsDictLam dicts expr = DictLam dicts expr
-\end{code}
-%************************************************************************
-%* *
-\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
-%* *
-%************************************************************************
+mkHsLet EmptyMonoBinds expr = expr
+mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
-Some gruesome hackery for desugaring ccalls. It's here because if we put it
-in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
-DsCCall.lhs.
+mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
-\begin{code}
-maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
-maybeBoxedPrimType ty
- = case splitAlgTyConApp_maybe ty of -- Data type,
- Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor
- -> case (dataConArgTys data_con tys_applied) of
- [data_con_arg_ty] -- Applied to exactly one type,
- | isUnLiftedType data_con_arg_ty -- which is primitive
- -> Just (data_con, data_con_arg_ty)
- other_cases -> Nothing
- other_cases -> Nothing
+idsToMonoBinds :: [Id] -> TcMonoBinds
+idsToMonoBinds ids
+ = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
+ | id <- ids
+ ]
\end{code}
%************************************************************************
\begin{code}
-- zonkId is used *during* typechecking just to zonk the Id's type
-zonkId :: TcId -> NF_TcM s TcId
+zonkId :: TcId -> NF_TcM TcId
zonkId id
= zonkTcType (idType id) `thenNF_Tc` \ ty' ->
returnNF_Tc (setIdType id ty')
-- zonkIdBndr is used *after* typechecking to get the Id's type
-- to its final form. The TyVarEnv give
-zonkIdBndr :: TcId -> NF_TcM s Id
+zonkIdBndr :: TcId -> NF_TcM Id
zonkIdBndr id
= zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
returnNF_Tc (setIdType id ty')
-zonkIdOcc :: TcId -> NF_TcM s Id
+zonkIdOcc :: TcId -> NF_TcM Id
zonkIdOcc id
- | not (isLocallyDefined id) || omitIfaceSigForId id
- -- The omitIfaceSigForId thing may look wierd but it's quite
- -- sensible really. We're avoiding looking up superclass selectors
+ | not (isLocalId id) || isIP id
+ -- We're avoiding looking up superclass selectors
-- and constructors; zonking them is a no-op anyway, and the
-- superclass selectors aren't in the environment anyway.
= returnNF_Tc id
| otherwise
- = tcLookupValueMaybe (idName id) `thenNF_Tc` \ maybe_id' ->
+ = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
let
new_id = case maybe_id' of
- Just id' -> id'
- Nothing -> pprTrace "zonkIdOcc: " (ppr id) id
+ Just (AnId id') -> id'
+ other -> pprTrace "zonkIdOcc:" (ppr id) id
in
returnNF_Tc new_id
\end{code}
\begin{code}
-zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv)
+zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
zonkTopBinds binds -- Top level is implicitly recursive
= fixNF_Tc (\ ~(_, new_ids) ->
tcExtendGlobalValEnv (bagToList new_ids) $
zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
- tcGetValueEnv `thenNF_Tc` \ env ->
+ tcGetEnv `thenNF_Tc` \ env ->
returnNF_Tc ((binds', env), new_ids)
) `thenNF_Tc` \ (stuff, _) ->
returnNF_Tc stuff
-zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv)
+zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
zonkBinds binds
= go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
where
-- go :: TcHsBinds
-- -> (TypecheckedHsBinds
- -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
+ -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
-- )
- -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
+ -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
go b2 $ \ b2' ->
fixNF_Tc (\ ~(_, new_ids) ->
tcExtendGlobalValEnv (bagToList new_ids) $
zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
- thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
+ thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
returnNF_Tc (stuff, new_ids)
) `thenNF_Tc` \ (stuff, _) ->
returnNF_Tc stuff
\begin{code}
-------------------------------------------------------------------------
zonkMonoBinds :: TcMonoBinds
- -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
+ -> NF_TcM (TypecheckedMonoBinds, Bag Id)
zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
-zonkMonoBinds (AbsBinds tyvars dicts exports val_bind)
+zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
-- No need to extend tyvar env: the effects are
-- propagated through binding the tyvars themselves
let
new_globals = listToBag [global | (_, global, local) <- new_exports]
in
- returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
+ returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
new_globals)
where
zonkExport (tyvars, global, local)
- = mapNF_Tc zonkTcTyVarBndr tyvars `thenNF_Tc` \ new_tyvars ->
- zonkIdBndr global `thenNF_Tc` \ new_global ->
- zonkIdOcc local `thenNF_Tc` \ new_local ->
+ = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
+ -- This isn't the binding occurrence of these tyvars
+ -- but they should *be* tyvars. Hence zonkTcSigTyVars.
+ zonkIdBndr global `thenNF_Tc` \ new_global ->
+ zonkIdOcc local `thenNF_Tc` \ new_local ->
returnNF_Tc (new_tyvars, new_global, new_local)
\end{code}
%************************************************************************
\begin{code}
-zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch
+zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
zonkMatch (Match _ pats _ grhss)
= zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
-------------------------------------------------------------------------
zonkGRHSs :: TcGRHSs
- -> NF_TcM s TypecheckedGRHSs
+ -> NF_TcM TypecheckedGRHSs
zonkGRHSs (GRHSs grhss binds (Just ty))
= zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
%************************************************************************
\begin{code}
-zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
+zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
zonkExpr (HsVar id)
= zonkIdOcc id `thenNF_Tc` \ id' ->
returnNF_Tc (HsVar id')
-zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
+zonkExpr (HsIPVar id)
+ = zonkIdOcc id `thenNF_Tc` \ id' ->
+ returnNF_Tc (HsIPVar id')
-zonkExpr (HsLitOut lit ty)
+zonkExpr (HsLit (HsRat f ty))
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (HsLitOut lit new_ty)
+ returnNF_Tc (HsLit (HsRat f new_ty))
+
+zonkExpr (HsLit (HsLitLit lit ty))
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (HsLit (HsLitLit lit new_ty))
+
+zonkExpr (HsLit lit)
+ = returnNF_Tc (HsLit lit)
+
+-- HsOverLit doesn't appear in typechecker output
zonkExpr (HsLam match)
= zonkMatch match `thenNF_Tc` \ new_match ->
zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
+zonkExpr (HsWith expr binds)
+ = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
+ tcExtendGlobalValEnv (map fst new_binds) $
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (HsWith new_expr new_binds)
+ where
+ zonkIPBinds = mapNF_Tc zonkIPBind
+ zonkIPBind (n, e) =
+ zonkIdBndr n `thenNF_Tc` \ n' ->
+ zonkExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (n', e')
+
zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
= mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
returnNF_Tc (ExplicitTuple new_exprs boxed)
-zonkExpr (HsCon data_con tys exprs)
- = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
- mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (HsCon data_con new_tys new_exprs)
-
zonkExpr (RecordConOut data_con con_expr rbinds)
= zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
zonkArithSeq info `thenNF_Tc` \ new_info ->
returnNF_Tc (ArithSeqOut new_expr new_info)
-zonkExpr (CCall fun args may_gc is_casm result_ty)
+zonkExpr (HsCCall fun args may_gc is_casm result_ty)
= mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
- returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
+ returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
-zonkExpr (HsSCC label expr)
+zonkExpr (HsSCC lbl expr)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (HsSCC label new_expr)
+ returnNF_Tc (HsSCC lbl new_expr)
zonkExpr (TyLam tyvars expr)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
-------------------------------------------------------------------------
-zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
+zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
zonkArithSeq (From e)
= zonkExpr e `thenNF_Tc` \ new_e ->
-------------------------------------------------------------------------
zonkStmts :: [TcStmt]
- -> NF_TcM s [TypecheckedStmt]
+ -> NF_TcM [TypecheckedStmt]
zonkStmts [] = returnNF_Tc []
+zonkStmts (ParStmtOut bndrstmtss : stmts)
+ = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
+ let new_binders = concat new_bndrss in
+ mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
+ tcExtendGlobalValEnv new_binders $
+ zonkStmts stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
+ where (bndrss, stmtss) = unzip bndrstmtss
+
zonkStmts [ReturnStmt expr]
= zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc [ReturnStmt new_expr]
-------------------------------------------------------------------------
-zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
+zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
zonkRbinds rbinds
= mapNF_Tc zonk_rbind rbinds
%************************************************************************
\begin{code}
-zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id)
+zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
zonkPat (WildPat ty)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
\begin{code}
-zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl]
+zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
-zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl)
+zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
zonkIdOcc i `thenNF_Tc` \ i' ->
returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
\end{code}
+
+\begin{code}
+zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
+zonkRules rs = mapNF_Tc zonkRule rs
+
+zonkRule (HsRule name tyvars vars lhs rhs loc)
+ = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
+ mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
+ tcExtendGlobalValEnv new_bndrs $
+ zonkExpr lhs `thenNF_Tc` \ new_lhs ->
+ zonkExpr rhs `thenNF_Tc` \ new_rhs ->
+ returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
+ -- I hate this map RuleBndr stuff
+
+zonkRule (IfaceRuleOut fun rule)
+ = zonkIdOcc fun `thenNF_Tc` \ fun' ->
+ returnNF_Tc (IfaceRuleOut fun' rule)
+\end{code}
projects / ghc-hetmet.git / blobdiff