X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=9dc5fcafce8701b98794b08e743b12c51e3d9ef3;hb=a76db2a07f99716c40e05d73210f80b4e4794b9a;hp=d4bd29b563f17cd761dda8967b3051361682170c;hpb=e87d56ce33f663da1c445f37e95c40d814caa384;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index d4bd29b..9dc5fca 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,27 +39,22 @@ module TcHsSyn (
 import HsSyn	-- oodles of it
 
 -- others:
-import Id	( idName, idType, setIdType, omitIfaceSigForId, isIP, Id )
-import DataCon	( DataCon, splitProductType_maybe )	
-import TcEnv	( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
-		  ValueEnv, TcId, tcInstId
+import Id	( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, 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}
 
 
@@ -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}
 
 %************************************************************************
@@ -170,19 +151,19 @@ the environment manipulation is tiresome.
 
 \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 || isIP id
 	-- The omitIfaceSigForId thing may look wierd but it's quite
@@ -191,28 +172,28 @@ zonkIdOcc id
 	-- 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 -> 
@@ -220,9 +201,9 @@ zonkBinds binds
   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' ->
@@ -244,7 +225,7 @@ zonkBinds binds
 \begin{code}
 -------------------------------------------------------------------------
 zonkMonoBinds :: TcMonoBinds
-	      -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
+	      -> NF_TcM (TypecheckedMonoBinds, Bag Id)
 
 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 
@@ -295,9 +276,11 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines 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}
 
@@ -308,7 +291,7 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
 %************************************************************************
 
 \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) ->
@@ -318,7 +301,7 @@ zonkMatch (Match _ pats _ grhss)
 
 -------------------------------------------------------------------------
 zonkGRHSs :: TcGRHSs
-	  -> NF_TcM s TypecheckedGRHSs
+	  -> NF_TcM TypecheckedGRHSs
 
 zonkGRHSs (GRHSs grhss binds (Just ty))
   = zonkBinds binds   		`thenNF_Tc` \ (new_binds, new_env) ->
@@ -340,7 +323,7 @@ zonkGRHSs (GRHSs grhss binds (Just ty))
 %************************************************************************
 
 \begin{code}
-zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
+zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
 
 zonkExpr (HsVar id)
   = zonkIdOcc id	`thenNF_Tc` \ id' ->
@@ -350,11 +333,18 @@ zonkExpr (HsIPVar id)
   = zonkIdOcc id	`thenNF_Tc` \ id' ->
     returnNF_Tc (HsIPVar id')
 
-zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
+zonkExpr (HsLit (HsRat f ty))
+  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty  ->
+    returnNF_Tc (HsLit (HsRat f new_ty))
 
-zonkExpr (HsLitOut lit ty)
+zonkExpr (HsLit (HsLitLit lit ty))
   = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty  ->
-    returnNF_Tc (HsLitOut lit 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 ->
@@ -402,14 +392,16 @@ zonkExpr (HsLet binds expr)
     returnNF_Tc (HsLet new_binds new_expr)
 
 zonkExpr (HsWith expr binds)
-  = zonkExpr expr		`thenNF_Tc` \ new_expr ->
-    zonkIPBinds binds		`thenNF_Tc` \ new_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')
+	    returnNF_Tc (n', e')
 
 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 
@@ -433,11 +425,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 +447,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 ->
@@ -495,7 +482,7 @@ zonkExpr (DictApp expr dicts)
 
 
 -------------------------------------------------------------------------
-zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
+zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
 
 zonkArithSeq (From e)
   = zonkExpr e		`thenNF_Tc` \ new_e ->
@@ -519,7 +506,7 @@ zonkArithSeq (FromThenTo e1 e2 e3)
 
 -------------------------------------------------------------------------
 zonkStmts :: [TcStmt]
-	  -> NF_TcM s [TypecheckedStmt]
+	  -> NF_TcM [TypecheckedStmt]
 
 zonkStmts [] = returnNF_Tc []
 
@@ -553,7 +540,7 @@ zonkStmts (BindStmt pat expr locn : stmts)
 
 
 -------------------------------------------------------------------------
-zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
+zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
 
 zonkRbinds rbinds
   = mapNF_Tc zonk_rbind rbinds
@@ -571,7 +558,7 @@ zonkRbinds 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 ->
@@ -661,28 +648,29 @@ zonkPats (pat:pats)
 
 
 \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 s [TypecheckedRuleDecl]
+zonkRules :: [TcRuleDecl] -> NF_TcM [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}