X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=21ca4be9b43c6cf9016dc3f9e2b8161c91b25aa7;hb=d68887047bcfb9021151f768fe1a22df2d3fbe1e;hp=41e44c5a4e9709268f267f79101385daf0aa3c20;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 41e44c5..21ca4be 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -22,15 +22,13 @@ module TcHsSyn (
 	TypecheckedGRHSs, TypecheckedGRHS,
 	TypecheckedRecordBinds, TypecheckedDictBinds,
 
-	mkHsTyApp, mkHsDictApp,
+	mkHsTyApp, mkHsDictApp, mkHsConApp,
 	mkHsTyLam, mkHsDictLam, mkHsLet,
 
 	-- re-exported from TcEnv
-	TcId, tcInstId,
+	TcId, 
 
-	maybeBoxedPrimType,
-
-	zonkTopBinds, zonkId, zonkIdOcc,
+	zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
 	zonkForeignExports, zonkRules
   ) where
 
@@ -40,27 +38,20 @@ module TcHsSyn (
 import HsSyn	-- oodles of it
 
 -- others:
-import Id	( idName, idType, setIdType, omitIfaceSigForId, Id )
-import DataCon	( DataCon, dataConArgTys )	
-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 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 BasicTypes ( RecFlag(..) )
 import Bag
-import UniqFM
 import Outputable
+import HscTypes	( TyThing(..) )
 \end{code}
 
 
@@ -123,29 +114,8 @@ 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.
-
-\begin{code}
-maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
-maybeBoxedPrimType ty
-  = case splitAlgTyConApp_maybe ty of					-- Data type,
-      Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon 	-- with exactly one constructor
-        -> case (dataConArgTys data_con tys_applied) of
-	     [data_con_arg_ty]			    	-- Applied to exactly one type,
-	        | isUnLiftedType data_con_arg_ty 	-- which is primitive
-	        -> Just (data_con, data_con_arg_ty)
-	     other_cases -> Nothing
-      other_cases -> Nothing
+mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
 \end{code}
 
 %************************************************************************
@@ -172,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
-	-- 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 -> 
@@ -222,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' ->
@@ -237,7 +209,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
@@ -246,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)
 
@@ -297,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}
 
@@ -310,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) ->
@@ -320,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) ->
@@ -342,17 +316,28 @@ 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' ->
     returnNF_Tc (HsVar id')
 
-zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
+zonkExpr (HsIPVar id)
+  = zonkIdOcc id	`thenNF_Tc` \ id' ->
+    returnNF_Tc (HsIPVar id')
 
-zonkExpr (HsLitOut lit ty)
+zonkExpr (HsLit (HsRat f ty))
   = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty  ->
-    returnNF_Tc (HsLitOut lit new_ty)
+    returnNF_Tc (HsLit (HsRat f new_ty))
+
+zonkExpr (HsLit (HsLitLit lit ty))
+  = zonkTcTypeToType ty	    `thenNF_Tc` \ 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 ->
@@ -369,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 ->
@@ -399,6 +384,18 @@ zonkExpr (HsLet binds expr)
     zonkExpr expr	`thenNF_Tc` \ new_expr ->
     returnNF_Tc (HsLet new_binds new_expr)
 
+zonkExpr (HsWith expr 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')
+
 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 
 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
@@ -421,11 +418,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 ->
@@ -448,14 +440,14 @@ 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 label expr)
+zonkExpr (HsSCC lbl expr)
   = zonkExpr expr	`thenNF_Tc` \ new_expr ->
-    returnNF_Tc (HsSCC label new_expr)
+    returnNF_Tc (HsSCC lbl new_expr)
 
 zonkExpr (TyLam tyvars expr)
   = mapNF_Tc zonkTcTyVarToTyVar tyvars	`thenNF_Tc` \ new_tyvars ->
@@ -483,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 ->
@@ -507,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		$
@@ -541,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
@@ -559,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 ->
@@ -649,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}