{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
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 Control.Monad.ST.Imp
import System.IO
class (Monad m) => MonadFix m where
mfix :: (a -> m a) -> m a
instance MonadFix Maybe where
mfix :: (a -> Maybe a) -> Maybe a
mfix f :: a -> Maybe a
f = let a :: Maybe a
a = a -> Maybe a
f (Maybe a -> a
forall p. Maybe p -> p
unJust Maybe a
a) in Maybe a
a
where unJust :: Maybe p -> p
unJust (Just x :: p
x) = p
x
unJust Nothing = [Char] -> p
forall a. [Char] -> a
errorWithoutStackTrace "mfix Maybe: Nothing"
instance MonadFix [] where
mfix :: (a -> [a]) -> [a]
mfix f :: 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
[] -> []
(x :: a
x:_) -> 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)
instance MonadFix NonEmpty where
mfix :: (a -> NonEmpty a) -> NonEmpty a
mfix f :: 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
~(x :: a
x :| _) -> 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 ~(_ :| as :: [a]
as) = [a]
as
instance MonadFix IO where
mfix :: (a -> IO a) -> IO a
mfix = (a -> IO a) -> IO a
forall a. (a -> IO a) -> IO a
fixIO
instance MonadFix ((->) r) where
mfix :: (a -> r -> a) -> r -> a
mfix f :: a -> r -> a
f = \ r :: r
r -> let a :: a
a = a -> r -> a
f a
a r
r in a
a
instance MonadFix (Either e) where
mfix :: (a -> Either e a) -> Either e a
mfix f :: a -> Either e a
f = let a :: Either e a
a = a -> Either e a
f (Either e a -> a
forall a p. Either a p -> p
unRight Either e a
a) in Either e a
a
where unRight :: Either a p -> p
unRight (Right x :: p
x) = p
x
unRight (Left _) = [Char] -> p
forall a. [Char] -> a
errorWithoutStackTrace "mfix Either: Left"
instance MonadFix (ST s) where
mfix :: (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
instance MonadFix Dual where
mfix :: (a -> Dual a) -> Dual a
mfix f :: 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))
instance MonadFix Sum where
mfix :: (a -> Sum a) -> Sum a
mfix f :: 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))
instance MonadFix Product where
mfix :: (a -> Product a) -> Product a
mfix f :: 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))
instance MonadFix First where
mfix :: (a -> First a) -> First a
mfix f :: 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))
instance MonadFix Last where
mfix :: (a -> Last a) -> Last a
mfix f :: 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))
instance MonadFix f => MonadFix (Alt f) where
mfix :: (a -> Alt f a) -> Alt f a
mfix f :: 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))
instance MonadFix f => MonadFix (Ap f) where
mfix :: (a -> Ap f a) -> Ap f a
mfix f :: 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))
instance MonadFix Par1 where
mfix :: (a -> Par1 a) -> Par1 a
mfix f :: 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))
instance MonadFix f => MonadFix (Rec1 f) where
mfix :: (a -> Rec1 f a) -> Rec1 f a
mfix f :: 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))
instance MonadFix f => MonadFix (M1 i c f) where
mfix :: (a -> M1 i c f a) -> M1 i c f a
mfix f :: 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 i (c :: Meta) k (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))
instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where
mfix :: (a -> (:*:) f g a) -> (:*:) f g a
mfix f :: 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 (a :: f p
a :*: _) = f p
a
sndP :: (:*:) f g p -> g p
sndP (_ :*: b :: g p
b) = g p
b
instance MonadFix Down where
mfix :: (a -> Down a) -> Down a
mfix f :: 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))
where getDown :: Down a -> a
getDown (Down x :: a
x) = a
x