X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=6c801895bf870ffb1140760fecd4b7ba7a768cc0;hp=4be039bd9326fe0f522a691b69e6125b079cb561;hb=fb38b8bab2b531ca7ac4ea28ad5b259a00e3759b;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 4be039b..6c80189 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -34,8 +34,8 @@ import SMRep		( argMachRep, primRepToCgRep, primRepHint )
 #endif
 import OccName		( mkForeignExportOcc )
 import Name		( Name, NamedThing(..), mkExternalName )
-import TcType		( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
-			  tcSplitForAllTys, 
+import TcType		( Type, tcSplitFunTys, 
+			  tcSplitForAllTys, tcSplitIOType_maybe,
 			  isFFIArgumentTy, isFFIImportResultTy, 
 			  isFFIExportResultTy, isFFILabelTy,
 			  isFFIExternalTy, isFFIDynArgumentTy,
@@ -45,7 +45,6 @@ import TcType		( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
 import ForeignCall	( CExportSpec(..), CCallTarget(..), 
 			  CLabelString, isCLabelString,
 			  isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) 
-import PrelNames	( hasKey, ioTyConKey )
 import DynFlags		( DynFlags(..), HscTarget(..) )
 import Outputable
 import SrcLoc		( Located(..), srcSpanStart )
@@ -59,12 +58,12 @@ import MachOp		( machRepByteWidth, MachHint(FloatHint) )
 \begin{code}
 -- Defines a binding
 isForeignImport :: LForeignDecl name -> Bool
-isForeignImport (L _ (ForeignImport _ _ _ _)) = True
+isForeignImport (L _ (ForeignImport _ _ _)) = True
 isForeignImport _			      = False
 
 -- Exports a binding
 isForeignExport :: LForeignDecl name -> Bool
-isForeignExport (L _ (ForeignExport _ _ _ _)) = True
+isForeignExport (L _ (ForeignExport _ _ _)) = True
 isForeignExport _	  	              = False
 \end{code}
 
@@ -80,7 +79,7 @@ tcForeignImports decls
   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
 
 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
-tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec)
+tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
  = addErrCtxt (foreignDeclCtxt fo)	$
    tcHsSigType (ForSigCtxt nm) hs_ty	`thenM`	\ sig_ty ->
    let 
@@ -96,7 +95,7 @@ tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec)
    tcCheckFIType sig_ty arg_tys res_ty imp_decl		`thenM` \ imp_decl' -> 
    -- can't use sig_ty here because it :: Type and we need HsType Id
    -- hence the undefined
-   returnM (id, ForeignImport (L loc id) undefined imp_decl' isDeprec)
+   returnM (id, ForeignImport (L loc id) undefined imp_decl')
 \end{code}
 
 
@@ -212,7 +211,7 @@ tcForeignExports decls
        returnM (b `consBag` binds, f:fs)
 
 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
-tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
    addErrCtxt (foreignDeclCtxt fo)	$
 
    tcHsSigType (ForSigCtxt nm) hs_ty	`thenM` \ sig_ty ->
@@ -233,7 +232,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
 	id   = mkExportedLocalId gnm sig_ty
 	bind = L loc (VarBind id rhs)
    in
-   returnM (bind, ForeignExport (L loc id) undefined spec isDeprec)
+   returnM (bind, ForeignExport (L loc id) undefined spec)
 \end{code}
 
 ------------ Checking argument types for foreign export ----------------------
@@ -277,17 +276,17 @@ nonIOok  = True
 mustBeIO = False
 
 checkForeignRes non_io_result_ok pred_res_ty ty
- = case tcSplitTyConApp_maybe ty of
-      Just (io, [res_ty]) 
-        | io `hasKey` ioTyConKey && pred_res_ty res_ty 
-	-> returnM ()
-      _   
-        -> check (non_io_result_ok && pred_res_ty ty) 
-		 (illegalForeignTyErr result ty)
+	-- (IO t) is ok, and so is any newtype wrapping thereof
+  | Just (io, res_ty) <- tcSplitIOType_maybe ty,
+    pred_res_ty res_ty
+  = returnM ()
+ 
+  | otherwise
+  = check (non_io_result_ok && pred_res_ty ty) 
+	  (illegalForeignTyErr result ty)
 \end{code}
 
 \begin{code}
-checkDotnet HscILX = Nothing
 #if defined(mingw32_TARGET_OS)
 checkDotnet HscC   = Nothing
 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
@@ -308,10 +307,9 @@ checkCOrAsmOrInterp other
 
 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
-checkCOrAsmOrDotNetOrInterp HscILX         = Nothing
 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
 checkCOrAsmOrDotNetOrInterp other  
-   = Just (text "requires interpreted, C, native or .NET ILX code generation")
+   = Just (text "requires interpreted, C or native code generation")
 
 checkCg check
  = getDOpts		`thenM` \ dflags ->