TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
- mkHsTyApp, mkHsDictApp,
+ mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
+ idsToMonoBinds,
-- re-exported from TcEnv
TcId, tcInstId,
- maybeBoxedPrimType,
-
zonkTopBinds, zonkId, zonkIdOcc,
zonkForeignExports, zonkRules
) where
import HsSyn -- oodles of it
-- others:
-import Id ( idName, idType, setIdType, omitIfaceSigForId, Id )
-import DataCon ( DataCon, splitProductType_maybe )
+import Id ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id )
+import DataCon ( DataCon, dataConWrapId, splitProductType_maybe )
import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
ValueEnv, TcId, tcInstId
)
import TcType ( TcType, TcTyVar,
zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
)
-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
\end{code}
mkHsLet EmptyMonoBinds expr = expr
mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
-%* *
-%************************************************************************
-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 splitProductType_maybe ty of -- Product data type
- Just (tycon, tys_applied, data_con, [data_con_arg_ty]) -- constr has one arg
- | isUnLiftedType data_con_arg_ty -- which is primitive
- -> Just (data_con, data_con_arg_ty)
-
- other_cases -> Nothing
+idsToMonoBinds :: [Id] -> TcMonoBinds
+idsToMonoBinds ids
+ = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
+ | id <- ids
+ ]
\end{code}
%************************************************************************
zonkIdOcc :: TcId -> NF_TcM s Id
zonkIdOcc id
- | not (isLocallyDefined id) || omitIfaceSigForId id
+ | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id
-- The omitIfaceSigForId thing may look wierd but it's quite
-- sensible really. We're avoiding looking up superclass selectors
-- and constructors; zonking them is a no-op anyway, and the
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
= zonkIdOcc id `thenNF_Tc` \ id' ->
returnNF_Tc (HsVar id')
+zonkExpr (HsIPVar id)
+ = zonkIdOcc id `thenNF_Tc` \ id' ->
+ returnNF_Tc (HsIPVar id')
+
zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
zonkExpr (HsLitOut lit ty)
zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
+zonkExpr (HsWith expr binds)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkIPBinds binds `thenNF_Tc` \ new_binds ->
+ returnNF_Tc (HsWith new_expr new_binds)
+ where
+ zonkIPBinds = mapNF_Tc zonkIPBind
+ zonkIPBind (n, e) =
+ 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 lbl expr)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl]
zonkRules rs = mapNF_Tc zonkRule rs
-zonkRule (RuleDecl name tyvars vars lhs rhs loc)
+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 (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
+ returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
-- I hate this map RuleBndr stuff
-zonkRule (IfaceRuleDecl fun rule loc)
- = returnNF_Tc (IfaceRuleDecl fun rule loc)
+zonkRule (IfaceRuleOut fun rule)
+ = zonkIdOcc fun `thenNF_Tc` \ fun' ->
+ returnNF_Tc (IfaceRuleOut fun' rule)
\end{code}
projects / ghc-hetmet.git / blobdiff