From 7e8f2da24a671fa3b314e49f244cabe37af7ccd2 Mon Sep 17 00:00:00 2001
From: Simon Marlow <marlowsd@gmail.com>
Date: Wed, 22 Jul 2009 10:21:30 +0000
Subject: [PATCH] Move the instances of Functor and Monad IO to GHC.Base, to
 avoid orphans

---
 GHC/Base.lhs   |   33 +++++++++++++++++++++++++++++++++
 GHC/IO.hs      |   33 +--------------------------------
 GHC/IO.hs-boot |    5 +++++
 GHC/IOBase.hs  |    1 +
 GHC/Weak.lhs   |    1 -
 5 files changed, 40 insertions(+), 33 deletions(-)
 create mode 100644 GHC/IO.hs-boot

diff --git a/GHC/Base.lhs b/GHC/Base.lhs
index 449a861..71876d3 100644
--- a/GHC/Base.lhs
+++ b/GHC/Base.lhs
@@ -103,6 +103,7 @@ import GHC.Ordering
 import GHC.Prim
 import {-# SOURCE #-} GHC.Show
 import {-# SOURCE #-} GHC.Err
+import {-# SOURCE #-} GHC.IO (failIO)
 
 -- These two are not strictly speaking required by this module, but they are
 -- implicit dependencies whenever () or tuples are mentioned, so adding them
@@ -710,6 +711,38 @@ asTypeOf                =  const
 
 %*********************************************************
 %*                                                      *
+\subsection{@Functor@ and @Monad@ instances for @IO@}
+%*                                                      *
+%*********************************************************
+
+\begin{code}
+instance  Functor IO where
+   fmap f x = x >>= (return . f)
+
+instance  Monad IO  where
+    {-# INLINE return #-}
+    {-# INLINE (>>)   #-}
+    {-# INLINE (>>=)  #-}
+    m >> k    = m >>= \ _ -> k
+    return    = returnIO
+    (>>=)     = bindIO
+    fail s    = GHC.IO.failIO s
+
+returnIO :: a -> IO a
+returnIO x = IO $ \ s -> (# s, x #)
+
+bindIO :: IO a -> (a -> IO b) -> IO b
+bindIO (IO m) k = IO $ \ s -> case m s of (# new_s, a #) -> unIO (k a) new_s
+
+thenIO :: IO a -> IO b -> IO b
+thenIO (IO m) k = IO $ \ s -> case m s of (# new_s, _ #) -> unIO k new_s
+
+unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
+unIO (IO a) = a
+\end{code}
+
+%*********************************************************
+%*                                                      *
 \subsection{@getTag@}
 %*                                                      *
 %*********************************************************
diff --git a/GHC/IO.hs b/GHC/IO.hs
index d1598ac..f2ccc7d 100644
--- a/GHC/IO.hs
+++ b/GHC/IO.hs
@@ -17,7 +17,7 @@
 
 -- #hide
 module GHC.IO (
-    IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, 
+    IO(..), unIO, failIO, liftIO,
     unsafePerformIO, unsafeInterleaveIO,
     unsafeDupablePerformIO, unsafeDupableInterleaveIO,
     noDuplicate,
@@ -65,40 +65,9 @@ Libraries - parts of hslibs/lang.
 --SDM
 -}
 
-unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
-unIO (IO a) = a
-
-instance  Functor IO where
-   fmap f x = x >>= (return . f)
-
-instance  Monad IO  where
-    {-# INLINE return #-}
-    {-# INLINE (>>)   #-}
-    {-# INLINE (>>=)  #-}
-    m >> k      =  m >>= \ _ -> k
-    return x    = returnIO x
-
-    m >>= k     = bindIO m k
-    fail s      = failIO s
-
 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
 
-bindIO :: IO a -> (a -> IO b) -> IO b
-bindIO (IO m) k = IO ( \ s ->
-  case m s of 
-    (# new_s, a #) -> unIO (k a) new_s
-  )
-
-thenIO :: IO a -> IO b -> IO b
-thenIO (IO m) k = IO ( \ s ->
-  case m s of 
-    (# new_s, _ #) -> unIO k new_s
-  )
-
-returnIO :: a -> IO a
-returnIO x = IO (\ s -> (# s, x #))
-
 failIO :: String -> IO a
 failIO s = IO (raiseIO# (toException (userError s)))
 
diff --git a/GHC/IO.hs-boot b/GHC/IO.hs-boot
new file mode 100644
index 0000000..703fad5
--- /dev/null
+++ b/GHC/IO.hs-boot
@@ -0,0 +1,5 @@
+module GHC.IO where
+
+import GHC.Types
+
+failIO :: [Char] -> IO a
diff --git a/GHC/IOBase.hs b/GHC/IOBase.hs
index cbadc87..dca72c0 100644
--- a/GHC/IOBase.hs
+++ b/GHC/IOBase.hs
@@ -50,6 +50,7 @@ module GHC.IOBase {-# DEPRECATED "use GHC.IO instead" #-} (
     blockedOnDeadMVar, blockedIndefinitely
   ) where
 
+import GHC.Base
 import GHC.Exception
 import GHC.IO
 import GHC.IO.Handle.Types
diff --git a/GHC/Weak.lhs b/GHC/Weak.lhs
index 23a3b01..4897123 100644
--- a/GHC/Weak.lhs
+++ b/GHC/Weak.lhs
@@ -20,7 +20,6 @@ module GHC.Weak where
 
 import GHC.Base
 import Data.Maybe
-import GHC.IO          ( unIO )
 import Data.Typeable
 
 {-|
-- 
1.7.10.4