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

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 4be039b..fc98fdb 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -35,7 +35,7 @@ import SMRep		( argMachRep, primRepToCgRep, primRepHint )
 import OccName		( mkForeignExportOcc )
 import Name		( Name, NamedThing(..), mkExternalName )
 import TcType		( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
-			  tcSplitForAllTys, 
+			  tcSplitForAllTys, tcSplitIOType_maybe,
 			  isFFIArgumentTy, isFFIImportResultTy, 
 			  isFFIExportResultTy, isFFILabelTy,
 			  isFFIExternalTy, isFFIDynArgumentTy,
@@ -277,13 +277,14 @@ 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}