    {-# 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 (Solo a -> a
    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 (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. [a] -> a
    head) of
                   []    -> []
                   (a
    x:[a]
    _) -> a
    x a -> [a] -> [a]
    forall a. a -> [a] -> [a]
    : (a -> [a]) -> [a]
    forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
    mfix ([a] -> [a]
    forall a. [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 (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 (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 (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 (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 (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 (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 (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 (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 (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))