[project @ 2000-04-05 16:25:51 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcHsSyn.lhs

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index e2ba970..e99c01d 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -22,14 +22,13 @@ module TcHsSyn (
        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
@@ -40,8 +39,8 @@ module TcHsSyn (
 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
                )
@@ -50,13 +49,13 @@ import TcMonad
 import TcType  ( TcType, TcTyVar,
                  zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
                )
-import TyCon   ( isDataTyCon )
-import Type    ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
+import Type    ( mkTyVarTy, 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
@@ -123,27 +122,14 @@ mkHsDictLam dicts expr = DictLam dicts expr
 
 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}
 
 %************************************************************************
@@ -184,7 +170,7 @@ zonkIdBndr id
 
 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
@@ -433,11 +419,6 @@ zonkExpr (ExplicitTuple exprs boxed)
   = 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 ->
@@ -460,10 +441,10 @@ zonkExpr (ArithSeqOut expr info)
     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 ->