{-# 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   :  stable
-- 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(..), Ap(..) )
import Data.Ord ( Down(..) )
import GHC.Base ( Monad, NonEmpty(..), errorWithoutStackTrace, (.) )
import GHC.Generics
import GHC.List ( head, tail )
import GHC.Tuple (Solo (..))
import Control.Monad.ST.Imp
import System.IO

-- | Monads having fixed points with a \'knot-tying\' semantics.
-- Instances of 'MonadFix' should satisfy the following laws:
--
-- [Purity]
--      @'mfix' ('Control.Monad.return' . h)  =  'Control.Monad.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 4.15
instance MonadFix Solo where
    mfix :: forall a. (a -> Solo a) -> Solo a
mfix a -> Solo a
f = let a :: Solo a
a = a -> Solo a
f (Solo a -> a
forall {a}. Solo a -> a
unSolo Solo a
a) in Solo a
a
             where unSolo :: Solo a -> a
unSolo (MkSolo a
x) = a
x

-- | @since 2.01
instance MonadFix Maybe where
    mfix :: forall a. (a -> Maybe a) -> Maybe a
mfix a -> Maybe a
f = let a :: Maybe a
a = a -> Maybe a
f (Maybe a -> a
forall {a}. Maybe a -> a
unJust Maybe a
a) in Maybe a
a
             where unJust :: Maybe a -> a
unJust (Just a
x) = a
x
                   unJust Maybe a
Nothing  = [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"mfix Maybe: Nothing"

-- | @since 2.01
instance MonadFix [] where
    mfix :: forall a. (a -> [a]) -> [a]
mfix a -> [a]
f = case ([a] -> [a]) -> [a]
forall a. (a -> a) -> a
fix (a -> [a]
f (a -> [a]) -> ([a] -> a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> a
forall a. HasCallStack => [a] -> a
head) of
               []    -> []
               (a
x:[a]
_) -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> [a]) -> [a]
forall a. (a -> [a]) -> [a]
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail ([a] -> [a]) -> (a -> [a]) -> a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
f)

-- | @since 4.9.0.0
instance MonadFix NonEmpty where
  mfix :: forall a. (a -> NonEmpty a) -> NonEmpty a
mfix a -> NonEmpty a
f = case (NonEmpty a -> NonEmpty a) -> NonEmpty a
forall a. (a -> a) -> a
fix (a -> NonEmpty a
f (a -> NonEmpty a) -> (NonEmpty a -> a) -> NonEmpty a -> NonEmpty a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> a
forall {a}. NonEmpty a -> a
neHead) of
             ~(a
x :| [a]
_) -> a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| (a -> [a]) -> [a]
forall a. (a -> [a]) -> [a]
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (NonEmpty a -> [a]
forall {a}. NonEmpty a -> [a]
neTail (NonEmpty a -> [a]) -> (a -> NonEmpty a) -> a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NonEmpty a
f)
    where
      neHead :: NonEmpty a -> a
neHead ~(a
a :| [a]
_) = a
a
      neTail :: NonEmpty a -> [a]
neTail ~(a
_ :| [a]
as) = [a]
as

-- | @since 2.01
instance MonadFix IO where
    mfix :: forall a. (a -> IO a) -> IO a
mfix = (a -> IO a) -> IO a
forall a. (a -> IO a) -> IO a
fixIO

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

-- | @since 4.3.0.0
instance MonadFix (Either e) where
    mfix :: forall a. (a -> Either e a) -> Either e a
mfix a -> Either e a
f = let a :: Either e a
a = a -> Either e a
f (Either e a -> a
forall {a} {b}. Either a b -> b
unRight Either e a
a) in Either e a
a
             where unRight :: Either a b -> b
unRight (Right b
x) = b
x
                   unRight (Left  a
_) = [Char] -> b
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"mfix Either: Left"

-- | @since 2.01
instance MonadFix (ST s) where
        mfix :: forall a. (a -> ST s a) -> ST s a
mfix = (a -> ST s a) -> ST s a
forall a s. (a -> ST s a) -> ST s a
fixST

-- Instances of Data.Monoid wrappers

-- | @since 4.8.0.0
instance MonadFix Dual where
    mfix :: forall a. (a -> Dual a) -> Dual a
mfix a -> Dual a
f   = a -> Dual a
forall a. a -> Dual a
Dual ((a -> a) -> a
forall a. (a -> a) -> a
fix (Dual a -> a
forall a. Dual a -> a
getDual (Dual a -> a) -> (a -> Dual a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Dual a
f))

-- | @since 4.8.0.0
instance MonadFix Sum where
    mfix :: forall a. (a -> Sum a) -> Sum a
mfix a -> Sum a
f   = a -> Sum a
forall a. a -> Sum a
Sum ((a -> a) -> a
forall a. (a -> a) -> a
fix (Sum a -> a
forall a. Sum a -> a
getSum (Sum a -> a) -> (a -> Sum a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Sum a
f))

-- | @since 4.8.0.0
instance MonadFix Product where
    mfix :: forall a. (a -> Product a) -> Product a
mfix a -> Product a
f   = a -> Product a
forall a. a -> Product a
Product ((a -> a) -> a
forall a. (a -> a) -> a
fix (Product a -> a
forall a. Product a -> a
getProduct (Product a -> a) -> (a -> Product a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Product a
f))

-- | @since 4.8.0.0
instance MonadFix First where
    mfix :: forall a. (a -> First a) -> First a
mfix a -> First a
f   = Maybe a -> First a
forall a. Maybe a -> First a
First ((a -> Maybe a) -> Maybe a
forall a. (a -> Maybe a) -> Maybe a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (First a -> Maybe a
forall a. First a -> Maybe a
getFirst (First a -> Maybe a) -> (a -> First a) -> a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> First a
f))

-- | @since 4.8.0.0
instance MonadFix Last where
    mfix :: forall a. (a -> Last a) -> Last a
mfix a -> Last a
f   = Maybe a -> Last a
forall a. Maybe a -> Last a
Last ((a -> Maybe a) -> Maybe a
forall a. (a -> Maybe a) -> Maybe a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (Last a -> Maybe a
forall a. Last a -> Maybe a
getLast (Last a -> Maybe a) -> (a -> Last a) -> a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Last a
f))

-- | @since 4.8.0.0
instance MonadFix f => MonadFix (Alt f) where
    mfix :: forall a. (a -> Alt f a) -> Alt f a
mfix a -> Alt f a
f   = f a -> Alt f a
forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt ((a -> f a) -> f a
forall a. (a -> f a) -> f a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (Alt f a -> f a
forall {k} (f :: k -> *) (a :: k). Alt f a -> f a
getAlt (Alt f a -> f a) -> (a -> Alt f a) -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Alt f a
f))

-- | @since 4.12.0.0
instance MonadFix f => MonadFix (Ap f) where
    mfix :: forall a. (a -> Ap f a) -> Ap f a
mfix a -> Ap f a
f   = f a -> Ap f a
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap ((a -> f a) -> f a
forall a. (a -> f a) -> f a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (Ap f a -> f a
forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp (Ap f a -> f a) -> (a -> Ap f a) -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Ap f a
f))

-- Instances for GHC.Generics
-- | @since 4.9.0.0
instance MonadFix Par1 where
    mfix :: forall a. (a -> Par1 a) -> Par1 a
mfix a -> Par1 a
f = a -> Par1 a
forall p. p -> Par1 p
Par1 ((a -> a) -> a
forall a. (a -> a) -> a
fix (Par1 a -> a
forall p. Par1 p -> p
unPar1 (Par1 a -> a) -> (a -> Par1 a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Par1 a
f))

-- | @since 4.9.0.0
instance MonadFix f => MonadFix (Rec1 f) where
    mfix :: forall a. (a -> Rec1 f a) -> Rec1 f a
mfix a -> Rec1 f a
f = f a -> Rec1 f a
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 ((a -> f a) -> f a
forall a. (a -> f a) -> f a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (Rec1 f a -> f a
forall k (f :: k -> *) (p :: k). Rec1 f p -> f p
unRec1 (Rec1 f a -> f a) -> (a -> Rec1 f a) -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rec1 f a
f))

-- | @since 4.9.0.0
instance MonadFix f => MonadFix (M1 i c f) where
    mfix :: forall a. (a -> M1 i c f a) -> M1 i c f a
mfix a -> M1 i c f a
f = f a -> M1 i c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 ((a -> f a) -> f a
forall a. (a -> f a) -> f a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (M1 i c f a -> f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1(M1 i c f a -> f a) -> (a -> M1 i c f a) -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> M1 i c f a
f))

-- | @since 4.9.0.0
instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where
    mfix :: forall a. (a -> (:*:) f g a) -> (:*:) f g a
mfix a -> (:*:) f g a
f = ((a -> f a) -> f a
forall a. (a -> f a) -> f a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((:*:) f g a -> f a
forall {f :: * -> *} {g :: * -> *} {p}. (:*:) f g p -> f p
fstP ((:*:) f g a -> f a) -> (a -> (:*:) f g a) -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (:*:) f g a
f)) f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: ((a -> g a) -> g a
forall a. (a -> g a) -> g a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((:*:) f g a -> g a
forall {f :: * -> *} {g :: * -> *} {p}. (:*:) f g p -> g p
sndP ((:*:) f g a -> g a) -> (a -> (:*:) f g a) -> a -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (:*:) f g a
f))
      where
        fstP :: (:*:) f g p -> f p
fstP (f p
a :*: g p
_) = f p
a
        sndP :: (:*:) f g p -> g p
sndP (f p
_ :*: g p
b) = g p
b

-- Instances for Data.Ord

-- | @since 4.12.0.0
instance MonadFix Down where
    mfix :: forall a. (a -> Down a) -> Down a
mfix a -> Down a
f = a -> Down a
forall a. a -> Down a
Down ((a -> a) -> a
forall a. (a -> a) -> a
fix (Down a -> a
forall a. Down a -> a
getDown (Down a -> a) -> (a -> Down a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Down a
f))

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.

Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy