X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=21ca4be9b43c6cf9016dc3f9e2b8161c91b25aa7;hb=33aac1f993ade9a0a8aee67eaad1584df8705d67;hp=e99c01daf55f0fb3a8980fbe3dfb52a6b09e5141;hpb=d4e0a55c3761544989209a2180d6d0489470db3d;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index e99c01d..21ca4be 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -24,12 +24,11 @@ module TcHsSyn (
 
 	mkHsTyApp, mkHsDictApp, mkHsConApp,
 	mkHsTyLam, mkHsDictLam, mkHsLet,
-	idsToMonoBinds,
 
 	-- re-exported from TcEnv
-	TcId, tcInstId,
+	TcId, 
 
-	zonkTopBinds, zonkId, zonkIdOcc,
+	zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
 	zonkForeignExports, zonkRules
   ) where
 
@@ -39,27 +38,20 @@ module TcHsSyn (
 import HsSyn	-- oodles of it
 
 -- others:
-import Id	( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id )
-import DataCon	( DataCon, dataConWrapId, splitProductType_maybe )	
-import TcEnv	( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
-		  ValueEnv, TcId, tcInstId
+import Id	( idName, idType, setIdType, Id )
+import DataCon	( dataConWrapId )	
+import TcEnv	( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
+		  TcEnv, TcId
 		)
 
 import TcMonad
-import TcType	( TcType, TcTyVar,
-		  zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
+import TcType	( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
 		)
-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
 import Outputable
+import HscTypes	( TyThing(..) )
 \end{code}
 
 
@@ -124,12 +116,6 @@ mkHsLet EmptyMonoBinds expr = expr
 mkHsLet mbinds	       expr = HsLet (MonoBind mbinds [] Recursive) expr
 
 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
-
-idsToMonoBinds :: [Id] -> TcMonoBinds 
-idsToMonoBinds ids
-  = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
-		    | id <- ids
-		    ]
 \end{code}
 
 %************************************************************************
@@ -156,49 +142,51 @@ 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
-	-- sensible really.  We're avoiding looking up superclass selectors
-	-- and constructors; zonking them is a no-op anyway, and the
+  = tcLookupGlobal_maybe (idName id)	`thenNF_Tc` \ maybe_id' ->
+	-- We're even look up up superclass selectors and constructors; 
+	-- even though 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' ->
+	-- But we don't want to call isLocalId to find out whether
+	-- it's a superclass selector (for example) because that looks
+	-- at the IdInfo field, which in turn be in a knot because of
+	-- the big knot in typecheckModule
     let
 	new_id = case maybe_id' of
-		    Just id' -> id'
-		    Nothing  -> pprTrace "zonkIdOcc: " (ppr id) id
+		    Just (AnId id') -> id'
+		    other  	    -> id -- WARN( isLocalId id, ppr id ) id
+					-- Oops: the warning can give a black hole
+					-- because it looks at the idinfo
     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 -> 
@@ -206,9 +194,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' ->
@@ -230,7 +218,7 @@ zonkBinds binds
 \begin{code}
 -------------------------------------------------------------------------
 zonkMonoBinds :: TcMonoBinds
-	      -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
+	      -> NF_TcM (TypecheckedMonoBinds, Bag Id)
 
 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 
@@ -281,9 +269,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}
 
@@ -294,7 +284,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) ->
@@ -304,7 +294,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) ->
@@ -326,7 +316,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' ->
@@ -336,11 +326,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 ->
@@ -357,8 +354,8 @@ zonkExpr (OpApp e1 op fixity e2)
     zonkExpr e2	`thenNF_Tc` \ new_e2 ->
     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 
-zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
-zonkExpr (HsPar _)    = panic "zonkExpr: HsPar"
+zonkExpr (NegApp _) = panic "zonkExpr: NegApp"
+zonkExpr (HsPar _)  = panic "zonkExpr: HsPar"
 
 zonkExpr (SectionL expr op)
   = zonkExpr expr	`thenNF_Tc` \ new_expr ->
@@ -388,14 +385,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"
 
@@ -476,7 +475,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 ->
@@ -500,24 +499,24 @@ zonkArithSeq (FromThenTo e1 e2 e3)
 
 -------------------------------------------------------------------------
 zonkStmts :: [TcStmt]
-	  -> NF_TcM s [TypecheckedStmt]
+	  -> NF_TcM [TypecheckedStmt]
 
 zonkStmts [] = returnNF_Tc []
 
-zonkStmts [ReturnStmt expr]
-  = zonkExpr expr		`thenNF_Tc` \ new_expr ->
-    returnNF_Tc [ReturnStmt new_expr]
+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 (ExprStmt expr locn : stmts)
   = zonkExpr expr	`thenNF_Tc` \ new_expr ->
     zonkStmts stmts	`thenNF_Tc` \ new_stmts ->
     returnNF_Tc (ExprStmt new_expr locn : new_stmts)
 
-zonkStmts (GuardStmt expr locn : stmts)
-  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
-    zonkStmts stmts	`thenNF_Tc` \ new_stmts ->
-    returnNF_Tc (GuardStmt new_expr locn : new_stmts)
-
 zonkStmts (LetStmt binds : stmts)
   = zonkBinds binds		`thenNF_Tc` \ (new_binds, new_env) ->
     tcSetEnv new_env		$
@@ -534,7 +533,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
@@ -552,7 +551,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 ->
@@ -642,28 +641,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}