Control/Monad/Fix.hs

    {-# LANGUAGE Trustworthy #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE TypeOperators #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Monad.Fix
    -- Copyright   :  (c) Andy Gill 2001,
    --                (c) Oregon Graduate Institute of Science and Technology, 2002
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    -- Maintainer  :  libraries@haskell.org
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- Monadic fixpoints.
    --
    -- For a detailed discussion, see Levent Erkok's thesis,
    -- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002.
    --
    -----------------------------------------------------------------------------

    module Control.Monad.Fix (
            MonadFix(mfix),
            fix
      ) where

    import Data.Either
    import Data.Function ( fix )
    import Data.Maybe
    import Data.Monoid ( Dual(..), Sum(..), Product(..)
                       , First(..), Last(..), Alt(..) )
    import GHC.Base ( Monad, errorWithoutStackTrace, (.) )
    import GHC.Generics
    import GHC.List ( head, tail )
    import GHC.ST
    import System.IO

    -- | Monads having fixed points with a \'knot-tying\' semantics.
    -- Instances of 'MonadFix' should satisfy the following laws:
    --
    -- [/purity/]
    --      @'mfix' ('return' . h)  =  'return' ('fix' h)@
    --
    -- [/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@.
    --
    -- [/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

    -- Instances of MonadFix for Prelude monads

    -- | @since 2.01
    instance MonadFix Maybe where
        mfix f = let a = f (unJust a) in a
                 where unJust (Just x) = x
                       unJust Nothing  = errorWithoutStackTrace "mfix Maybe: Nothing"

    -- | @since 2.01
    instance MonadFix [] where
        mfix f = case fix (f . head) of
                   []    -> []
                   (x:_) -> x : mfix (tail . f)

    -- | @since 2.01
    instance MonadFix IO where
        mfix = fixIO

    -- | @since 2.01
    instance MonadFix ((->) r) where
        mfix f = \ r -> let a = f a r in a

    -- | @since 4.3.0.0
    instance MonadFix (Either e) where
        mfix f = let a = f (unRight a) in a
                 where unRight (Right x) = x
                       unRight (Left  _) = errorWithoutStackTrace "mfix Either: Left"

    -- | @since 2.01
    instance MonadFix (ST s) where
            mfix = fixST

    -- Instances of Data.Monoid wrappers

    -- | @since 4.8.0.0
    instance MonadFix Dual where
        mfix f   = Dual (fix (getDual . f))

    -- | @since 4.8.0.0
    instance MonadFix Sum where
        mfix f   = Sum (fix (getSum . f))

    -- | @since 4.8.0.0
    instance MonadFix Product where
        mfix f   = Product (fix (getProduct . f))

    -- | @since 4.8.0.0
    instance MonadFix First where
        mfix f   = First (mfix (getFirst . f))

    -- | @since 4.8.0.0
    instance MonadFix Last where
        mfix f   = Last (mfix (getLast . f))

    -- | @since 4.8.0.0
    instance MonadFix f => MonadFix (Alt f) where
        mfix f   = Alt (mfix (getAlt . f))

    -- Instances for GHC.Generics
    -- | @since 4.9.0.0
    instance MonadFix Par1 where
        mfix f = Par1 (fix (unPar1 . f))

    -- | @since 4.9.0.0
    instance MonadFix f => MonadFix (Rec1 f) where
        mfix f = Rec1 (mfix (unRec1 . f))

    -- | @since 4.9.0.0
    instance MonadFix f => MonadFix (M1 i c f) where
        mfix f = M1 (mfix (unM1. f))

    -- | @since 4.9.0.0
    instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where
        mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f))
          where
            fstP (a :*: _) = a
            sndP (_ :*: b) = b