X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=1252cfd913dec93742809473c73950a1ef2ba6af;hb=ff755dd9a0a0ad2f106c323852553ea247f16141;hp=98c4a903c8b1c8ab1496fe184e3be68cdcb9c470;hpb=4e7d56fde0f44d38bbb9a6fc72cf9c603264899d;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 98c4a90..1252cfd 100644
--- 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,16 +49,11 @@ import TcMonad
 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}
 
@@ -123,27 +117,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 +165,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
@@ -235,7 +216,7 @@ zonkBinds binds
 	    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
@@ -346,6 +327,10 @@ zonkExpr (HsVar id)
   = 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)
@@ -397,6 +382,16 @@ zonkExpr (HsLet binds expr)
     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)
@@ -419,11 +414,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 ->
@@ -446,10 +436,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 ->
@@ -660,15 +650,16 @@ zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
 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}