{-# 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(..), 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 (forall {a}. Solo a -> a
unSolo Solo a
a) in Solo a
a
             where unSolo :: Solo a -> a
unSolo (Solo 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 (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  = 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 forall a. (a -> a) -> a
fix (a -> [a]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) of
               []    -> []
               (a
x:[a]
_) -> a
x forall a. a -> [a] -> [a]
: forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall a. [a] -> [a]
tail 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 forall a. (a -> a) -> a
fix (a -> NonEmpty a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. NonEmpty a -> a
neHead) of
             ~(a
x :| [a]
_) -> a
x forall a. a -> [a] -> NonEmpty a
:| forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall {a}. NonEmpty a -> [a]
neTail 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 = 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 (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
_) = 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 = 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   = forall a. a -> Dual a
Dual (forall a. (a -> a) -> a
fix (forall a. Dual a -> a
getDual 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   = forall a. a -> Sum a
Sum (forall a. (a -> a) -> a
fix (forall a. Sum a -> a
getSum 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   = forall a. a -> Product a
Product (forall a. (a -> a) -> a
fix (forall a. Product a -> a
getProduct 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   = forall a. Maybe a -> First a
First (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall a. First a -> Maybe a
getFirst 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   = forall a. Maybe a -> Last a
Last (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall a. Last a -> Maybe a
getLast 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   = forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall {k} (f :: k -> *) (a :: k). Alt f a -> f a
getAlt 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   = forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp 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 = forall p. p -> Par1 p
Par1 (forall a. (a -> a) -> a
fix (forall p. Par1 p -> p
unPar1 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 = forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall k (f :: k -> *) (p :: k). Rec1 f p -> f p
unRec1 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 = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1forall 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 = (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall {f :: * -> *} {g :: * -> *} {p}. (:*:) f g p -> f p
fstP forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (:*:) f g a
f)) forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall {f :: * -> *} {g :: * -> *} {p}. (:*:) f g p -> g p
sndP 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 = forall a. a -> Down a
Down (forall a. (a -> a) -> a
fix (forall a. Down a -> a
getDown forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Down a
f))