From: sof <unknown>
Date: Tue, 19 Jan 1999 15:19:24 +0000 (+0000)
Subject: [project @ 1999-01-19 15:19:23 by sof]
X-Git-Tag: Approx_2487_patches~45
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=bfd50cd8881723ad87c83a758c898784fa61b7c3

[project @ 1999-01-19 15:19:23 by sof]
Types of foreign imports weren't being zonked, with the lethal conseq.
that any unbound kind variables weren't being defaulted to something
sensible.

Showed up when trying to compile a 'foreign import' with type

  StablePtr a -> IO ()
---

diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index cf850f1..3208c7b 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -28,7 +28,7 @@ import RnHsSyn		( RenamedHsDecl, RenamedForeignDecl )
 import TcMonad
 import TcEnv		( newLocalId )
 import TcType		( tcInstTcType, typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
-import TcMonoType	( tcHsType )
+import TcMonoType	( tcHsTopBoxedType )
 import TcHsSyn		( TcMonoBinds, TypecheckedForeignDecl,
 			  TcForeignExportDecl )
 import TcExpr		( tcId, tcPolyExpr )			
@@ -92,7 +92,7 @@ tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
 tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
    tcAddSrcLoc src_loc		     $
    tcAddErrCtxt (foreignDeclCtxt fo) $
-   tcHsType hs_ty		    `thenTc`	\ sig_ty ->
+   tcHsTopBoxedType hs_ty	     `thenTc`	\ sig_ty ->
    let
       -- drop the foralls before inspecting the structure
       -- of the foreign type.
@@ -107,7 +107,7 @@ tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
 tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc		     $
    tcAddErrCtxt (foreignDeclCtxt fo) $
-   tcHsType hs_ty		    `thenTc`	\ sig_ty ->
+   tcHsTopBoxedType hs_ty	    `thenTc`	\ sig_ty ->
    let
       -- drop the foralls before inspecting the structure
       -- of the foreign type.
@@ -121,7 +121,7 @@ tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc		     $
    tcAddErrCtxt (foreignDeclCtxt fo) $
 
-   tcHsType hs_ty		     `thenTc` \ ty ->
+   tcHsTopBoxedType hs_ty	     `thenTc` \ ty ->
     -- Check that the type has the right shape
     -- and that the argument and result types are acceptable.
    let
@@ -140,7 +140,7 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc		     $
    tcAddErrCtxt (foreignDeclCtxt fo) $
 
-   tcHsType hs_ty		       `thenTc`	\ sig_ty ->
+   tcHsTopBoxedType hs_ty	       `thenTc`	\ sig_ty ->
    let sig_tc_ty = typeToTcType sig_ty in
    tcPolyExpr (HsVar nm) sig_tc_ty     `thenTc`    \ (rhs, lie, _, _, _) ->
 
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 3f2eedb..0358f11 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -254,7 +254,7 @@ tcModule rn_name_supply
 	in
 	zonkTopBinds all_binds		`thenNF_Tc` \ (all_binds', really_final_env)  ->
 	tcSetValueEnv really_final_env	$
-	zonkForeignExports foe_decls	`thenNF_Tc` \ foe_decls' ->
+	zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
 
 	let
 	   thin_air_ids = map (explicitLookupValueByKey really_final_env . nameUnique) thinAirIdNames
@@ -264,7 +264,7 @@ tcModule rn_name_supply
 	in
 	returnTc (really_final_env, 
 		  (all_binds', local_tycons, local_classes, inst_info,
-		   foi_decls ++ foe_decls',
+		   (foi_decls ++ foe_decls'),
 		   really_final_env,
 		   thin_air_ids))
 	)