Move the instances of Functor and Monad IO to GHC.Base, to avoid orphans

1 files changed, 33 insertions, 0 deletions

diff --git a/libraries/base/GHC/Base.lhs b/libraries/base/GHC/Base.lhs
index 449a86163d..71876d3aad 100644
--- a/libraries/base/GHC/Base.lhs
+++ b/libraries/base/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@}
 %*                                                      *
 %*********************************************************