X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FMonad%2FFix.hs;h=a1309faccd41db6574dc8bd5f36297708d635b35;hb=41e8fba828acbae1751628af50849f5352b27873;hp=b66a6cea9afa8446c5126a65779e097e02d817d4;hpb=f158833ab231d7532328591acf57c590091f79f1;p=ghc-base.git

diff --git a/Control/Monad/Fix.hs b/Control/Monad/Fix.hs
index b66a6ce..a1309fa 100644
--- a/Control/Monad/Fix.hs
+++ b/Control/Monad/Fix.hs
@@ -1,8 +1,10 @@
+{-# LANGUAGE CPP #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.Fix
 -- Copyright   :  (c) Andy Gill 2001,
--- 		  (c) Oregon Graduate Institute of Science and Technology, 2002
+--                (c) Oregon Graduate Institute of Science and Technology, 2002
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- Maintainer  :  libraries@haskell.org
 -- Stability   :  experimental
@@ -10,49 +12,55 @@
 --
 -- Monadic fixpoints.
 --
--- For more details, see Levent Erkok's thesis,
--- /Value Recursion in Monadic Computations/, 2002.
+-- For a detailed discussion, see Levent Erkok's thesis,
+-- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002.
 --
 -----------------------------------------------------------------------------
 
 module Control.Monad.Fix (
-	MonadFix(
-	   mfix	-- :: (a -> m a) -> m a
+        MonadFix(
+           mfix -- :: (a -> m a) -> m a
          ),
-	fix	-- :: (a -> a) -> a
+        fix     -- :: (a -> a) -> a
   ) where
 
 import Prelude
 import System.IO
+import Control.Monad.Instances ()
+import Data.Function (fix)
+#ifdef __HUGS__
+import Hugs.Prelude (MonadFix(mfix))
+#endif
+#if defined(__GLASGOW_HASKELL__)
+import GHC.ST
+#endif
 
--- | @'fix' f@ is the least fixed point of the function @f@.
-fix :: (a -> a) -> a
-fix f = let x = f x in x
-
--- | Monads having fixed points with a \`knot-tying\' semantics.
--- Instances of 'MonadFix' should satisfy the laws
+#ifndef __HUGS__
+-- | Monads having fixed points with a \'knot-tying\' semantics.
+-- Instances of 'MonadFix' should satisfy the following laws:
 --
--- [purity]
---	@'mfix' ('return' . h)  =  'return' ('fix' h)@
+-- [/purity/]
+--      @'mfix' ('return' . h)  =  'return' ('fix' h)@
 --
--- [left shrinking (or tightening)]
---	@'mfix' (\x -> a >>= \y -> f x y)  =  \y -> 'mfix' (\x -> f x y)@
+-- [/left shrinking/ (or /tightening/)]
+--      @'mfix' (\\x -> a >>= \\y -> f x y)  =  a >>= \\y -> 'mfix' (\\x -> f x y)@
 --
--- [sliding]
---	@'mfix' ('Control.Monad.liftM' h . f)  =  'Control.Monad.liftM' h ('mfix' (f . h))@,
---	for strict @h@.
+-- [/sliding/]
+--      @'mfix' ('Control.Monad.liftM' h . f)  =  'Control.Monad.liftM' h ('mfix' (f . h))@,
+--      for strict @h@.
 --
--- [nesting]
---	@'mfix' (\x -> 'mfix' (\y -> f x y))  =  'mfix' (\x -> f x x)@
+-- [/nesting/]
+--      @'mfix' (\\x -> 'mfix' (\\y -> f x y))  =  'mfix' (\\x -> f x x)@
 --
 -- This class is used in the translation of the recursive @do@ notation
 -- supported by GHC and Hugs.
 class (Monad m) => MonadFix m where
-	-- | The fixed point of a monadic computation.
-	-- @'mfix' f@ executes the action 'f' only once, with the eventual
-	-- output fed back as the input.  Hence @f@ should not be strict,
-	-- for then @'mfix' f@ would diverge.
-	mfix :: (a -> m a) -> m a
+        -- | The fixed point of a monadic computation.
+        -- @'mfix' f@ executes the action @f@ only once, with the eventual
+        -- output fed back as the input.  Hence @f@ should not be strict,
+        -- for then @'mfix' f@ would diverge.
+        mfix :: (a -> m a) -> m a
+#endif /* !__HUGS__ */
 
 -- Instances of MonadFix for Prelude monads
 
@@ -60,6 +68,7 @@ class (Monad m) => MonadFix m where
 instance MonadFix Maybe where
     mfix f = let a = f (unJust a) in a
              where unJust (Just x) = x
+                   unJust Nothing  = error "mfix Maybe: Nothing"
 
 -- List:
 instance MonadFix [] where
@@ -70,3 +79,19 @@ instance MonadFix [] where
 -- IO:
 instance MonadFix IO where
     mfix = fixIO 
+
+-- Prelude types with Monad instances in Control.Monad.Instances
+
+instance MonadFix ((->) r) where
+    mfix f = \ r -> let a = f a r in a
+
+instance MonadFix (Either e) where
+    mfix f = let a = f (unRight a) in a
+             where unRight (Right x) = x
+                   unRight (Left  _) = error "mfix Either: Left"
+
+#if defined(__GLASGOW_HASKELL__)
+instance MonadFix (ST s) where
+        mfix = fixST
+#endif
+