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 ()
import TcMonad
import TcEnv ( newLocalId )
import TcType ( tcInstTcType, typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
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 )
import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
TcForeignExportDecl )
import TcExpr ( tcId, tcPolyExpr )
tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
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.
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
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.
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
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
-- Check that the type has the right shape
-- and that the argument and result types are acceptable.
let
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
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, _, _, _) ->
let sig_tc_ty = typeToTcType sig_ty in
tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) ->
in
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
tcSetValueEnv really_final_env $
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
let
thin_air_ids = map (explicitLookupValueByKey really_final_env . nameUnique) thinAirIdNames
in
returnTc (really_final_env,
(all_binds', local_tycons, local_classes, inst_info,
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))
)
really_final_env,
thin_air_ids))
)