Control/Monad/X/Fix.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Control.Monad.Fix
   4 -- Copyright   :  (c) Andy Gill 2001,
   5 --                (c) Oregon Graduate Institute of Science and Technology, 2002
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  experimental
  10 -- Portability :  portable
  11 --
  12 -- A class for monadic (value) recursion and its implementation.
  13 -- For details:
  14 -- Levent Erkök. Value recursion in Monadic Computations.
  15 -- Oregon Graduate Institute, OHSU. Portland, Oregon. October 2002.
  16 -- http://www.cse.ogi.edu/~erkok/rmb/
  17 -----------------------------------------------------------------------------
  18
  19 module Control.Monad.X.Fix (
  20         MonadFix(
  21            mfix -- :: (a -> m a) -> m a
  22          ),
  23         fix     -- :: (a -> a) -> a
  24   ) where
  25
  26 import Prelude
  27 import System.IO
  28 import Monad(liftM)
  29
  30 import Control.Monad.X.Trans
  31 import Control.Monad.X.Identity
  32 import Control.Monad.X.Types
  33 import Control.Monad.X.ReaderT
  34 import Control.Monad.X.WriterT
  35 import Control.Monad.X.StateT
  36 import Control.Monad.X.ErrorT
  37 import Control.Monad.X.NondetT
  38
  39 fix :: (a -> a) -> a
  40 fix f = let x = f x in x
  41
  42 class (Monad m) => MonadFix m where
  43   mfix :: (a -> m a) -> m a
  44
  45
  46
  47
  48 instance MonadFix Maybe where
  49   mfix f  = let a = f (unJust a) in a
  50              where unJust (Just x) = x
  51
  52 instance MonadFix [] where
  53   mfix f  = case fix (f . head) of
  54               []    -> []
  55               (x:_) -> x : mfix (tail . f)
  56
  57 instance MonadFix IO where
  58   mfix    = fixIO
  59
  60 instance MonadFix Identity where
  61   mfix f  = return (fix (runIdentity . f))
  62
  63 instance (MonadFix m) => MonadFix (ReaderT r m) where
  64   mfix f  = R (\r -> mfix (\a -> unR (f a) r))
  65
  66 instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where
  67   mfix m  = W (mfix (\ ~(a, _) -> unW (m a)))
  68
  69 instance (MonadFix m) => MonadFix (StateT s m) where
  70   mfix f  = S (\s -> mfix (\ ~(a, _) -> unS (f a) s))
  71
  72 instance (MonadFix m) => MonadFix (ErrorT e m) where
  73   mfix f  = E (mfix (unE . f . either (error "ErrorT: mfix looped") id))
  74
  75 -- is that right?
  76 instance MonadFix m => MonadFix (NondetT m) where
  77   mfix f  = N (do x <- mfix (unN . f . hd)
  78                   case x of
  79                     Empty    -> return Empty
  80                     Cons a _ -> return (Cons a (mfix (tl . f))))
  81     where hd (Cons a _) = a
  82           hd _          = error "NondetT: mfix looped (hd)"
  83           tl m          = N (do x <- unN m
  84                                 case x of
  85                                   Cons _ m -> unN m
  86                                   _ -> error "NondetT: mfix looped (tl)")
  87
  88
  89 {-
  90 instance MonadFix m => MonadFix (NondetT m) where
  91   mfix f  = Re (do x <- mfix (unRe . f . hd)
  92                   case x of
  93                     Value a  -> return (Value a)
  94                     Delay m  -> return (Delay (mfix (tl . f)))
  95     where hd (Value a)  = a
  96           hd _          = error "ResumeT: mfix looped (hd)"
  97           tl m          = Re (do x <- unRe m
  98                                 case x of
  99
 100                                   Cons _ m -> unN m
 101                                   _ -> error "NondetT: mfix looped (tl)")
 102 -}
 103