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

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 4b6e7b8..0818437 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -82,7 +82,7 @@ module TcType (
   isFFIDotnetTy,       -- :: DynFlags -> Type -> Bool
   isFFIDotnetObjTy,    -- :: Type -> Bool
   isFFITy,	       -- :: Type -> Bool
-  
+  tcSplitIOType_maybe, -- :: Type -> Maybe Type  
   toDNType,            -- :: Type -> DNType
 
   --------------------------------
@@ -160,7 +160,7 @@ import Type		(	-- Re-exports
 		  	  substTy, substTys, substTyWith, substTheta, 
 			  substTyVar, substTyVarBndr, substPred, lookupTyVar,
 
-			  typeKind, repType,
+			  typeKind, repType, coreView,
 			  pprKind, pprParendKind,
 			  pprType, pprParendType, pprTyThingCategory,
 			  pprPred, pprTheta, pprThetaArrow, pprClassPred
@@ -1029,6 +1029,23 @@ restricted set of types as arguments and results (the restricting factor
 being the )
 
 \begin{code}
+tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
+-- (isIOType t) returns (Just (IO,t')) if t is of the form (IO t'), or
+--				       some newtype wrapping thereof
+--		returns Nothing otherwise
+tcSplitIOType_maybe ty 
+  | Just (io_tycon, [io_res_ty]) <- tcSplitTyConApp_maybe ty,
+	-- This split absolutely has to be a tcSplit, because we must
+	-- see the IO type; and it's a newtype which is transparent to splitTyConApp.
+    io_tycon `hasKey` ioTyConKey
+  = Just (io_tycon, io_res_ty)
+
+  | Just ty' <- coreView ty	-- Look through non-recursive newtypes
+  = tcSplitIOType_maybe ty'
+
+  | otherwise
+  = Nothing
+
 isFFITy :: Type -> Bool
 -- True for any TyCon that can possibly be an arg or result of an FFI call
 isFFITy ty = checkRepTyCon legalFFITyCon ty