module Control.ForFree (
Plus(..), OpT(..),
Yoneda(..), unreduceYoneda,
CoYoneda(..), reduceCoYoneda,
Free(..), reduceFree, affectFree, FreeT(..), reduceFreeT,
Cofree(..), unreduceCofree, affectCofree, CofreeT(..),
unreduceCofreeT,
Codensity(..), lowerCodensity,
Density(..), liftDensity,
CoT(..), Co, runCo, liftCoT0, lowerCoT0, lowerCo0, liftCoT1,
lowerCoT1, lowerCo1,
CodensityAsk(..), peekCodensityAsk, CodensityAskT(..),
peekCodensityAskT, lowerCodensityAskT, catchCodensityAsk,
catchCodensityAskT,
DensityAskT(..), DensityAsk, liftDensityAsk,
Finalize(..), Initialize(..), Decompose(..), Recompose(..),
Op(..), Endo(..), Const(..)
) where {
import Control.Applicative;
import Control.Arrow;
import Control.Category;
import Control.Comonad;
import Control.Comonad.Hoist.Class;
import Control.Comonad.Trans.Class;
import Control.Monad;
import Control.Monad.Trans.Class;
import Control.Monad.Trans.Maybe (MaybeT);
import Control.Monad.Trans.Reader (ReaderT(..));
import Control.Monad.Trans.RWS (RWST);
import Control.Monad.Trans.State (StateT);
import Control.Monad.Trans.Writer (WriterT(..));
import Data.Functor.Contravariant;
import Data.Functor.Identity;
import Data.IntMap (IntMap);
import Data.Map (Map);
import Data.Monoid;
import Data.Sequence (Seq);
import Prelude hiding (id, (.));
instance Monoid x => Alternative (Const x) where {
empty = Const mempty;
Const x <|> Const y = Const (mappend x y);
};
instance Monoid x => Plus (Const x) where {
zero = Const mempty;
plus (Const x) (Const y) = Const (mappend x y);
};
;
newtype OpT f a b = OpT { getOpT :: f b -> a };
instance Functor f => Contravariant (OpT f x) where {
contramap f (OpT x) = OpT (x . fmap f);
};
instance Comonad f => Category (OpT f) where {
id = OpT extract;
OpT x . OpT y = OpT (y =<= x);
};
;
class Plus f where {
zero :: f x;
plus :: f x -> f x -> f x;
};
instance Plus Endo where {
zero = mempty;
plus = mappend;
};
instance Monoid x => Plus (Op x) where {
zero = Op (const mempty);
plus (Op x) (Op y) = Op (liftA2 mappend x y);
};
instance Monoid x => Plus (OpT f x) where {
zero = OpT (const mempty);
plus (OpT x) (OpT y) = OpT (liftA2 mappend x y);
};
instance Plus Comparison where {
zero = Comparison (\_ _ -> EQ);
plus (Comparison x) (Comparison y) = Comparison (\a b -> mappend (x a b) (y a b));
};
;
newtype Yoneda f x = Yoneda { runYoneda :: forall z. (x -> z) -> f z };
instance Functor (Yoneda f) where {
fmap f (Yoneda x) = Yoneda (\k -> x (k . f));
};
instance Plus f => Plus (Yoneda f) where {
zero = Yoneda (const zero);
plus (Yoneda x) (Yoneda y) = Yoneda (liftA2 plus x y);
};
;
unreduceYoneda :: Functor w => (forall z. w z -> f z) -> w x -> Yoneda f x;
unreduceYoneda f x = Yoneda (\z -> f (z <$> x));
;
data CoYoneda f x = forall z. CoYoneda (z -> x) (f z);
instance Functor (CoYoneda f) where {
fmap f (CoYoneda x y) = CoYoneda (f . x) y;
};
;
reduceCoYoneda :: Functor m => (forall z. f z -> m z) -> CoYoneda f x -> m x;
reduceCoYoneda f (CoYoneda x y) = x <$> f y;
;
data Free f x = Pure x | Free (f (Free f x));
deriving instance (Eq (f (Free f a)), Eq a) => Eq (Free f a);
deriving instance (Ord (f (Free f a)), Ord a) => Ord (Free f a);
deriving instance (Read (f (Free f a)), Read a) => Read (Free f a);
deriving instance (Show (f (Free f a)), Show a) => Show (Free f a);
instance Functor f => Functor (Free f) where {
fmap f (Pure x) = Pure (f x);
fmap f (Free x) = Free (fmap f <$> x);
};
instance Functor f => Applicative (Free f) where {
pure = Pure;
Pure a <*> Pure b = Pure (a b);
Pure a <*> Free b = Free (fmap a <$> b);
Free a <*> b = Free ((<*> b) <$> a);
};
instance Functor f => Monad (Free f) where {
return = Pure;
Pure a >>= f = f a;
Free m >>= f = Free ((>>= f) <$> m);
};
joinFree :: Functor f => Free f (Free f x) -> Free f x;
joinFree (Pure x) = x;
joinFree (Free x) = Free (join <$> x);
instance (Functor f, Plus f) => Alternative (Free f) where {
empty = Free zero;
Pure x <|> _ = Pure x;
_ <|> Pure x = Pure x;
Free x <|> Free y = Free (plus x y);
};
instance (Functor f, Plus f) => MonadPlus (Free f) where {
mzero = empty;
mplus = (<|>);
};
instance Plus f => Plus (Free f) where {
zero = Free zero;
plus (Pure x) _ = Pure x;
plus _ (Pure x) = Pure x;
plus (Free x) (Free y) = Free (plus x y);
};
instance ComonadHoist Free where {
cohoist (Pure x) = Pure x;
cohoist (Free x) = Free (pure . cohoist $ extract x);
};
;
reduceFree :: Monad m => (forall z. f z -> m z) -> Free f x -> m x;
reduceFree f (Pure x) = return x;
reduceFree f (Free x) = f x >>= reduceFree f;
;
affectFree :: Functor g => (forall z. (s, f z) -> g (s, z)) -> (s, Free f x) -> Free g (s, x);
affectFree _ (s, Pure x) = Pure (s, x);
affectFree f (s, Free x) = Free (w f $ f (s, x)) where {
w :: Functor g => (forall z. (s, f z) -> g (s, z)) -> g (s, Free f x) -> g (Free g (s, x));
w f' x' = affectFree f' <$> x';
};
;
data Cofree f x = x :< f (Cofree f x);
infixr 5 :<;
deriving instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a);
deriving instance (Ord (f (Cofree f a)), Ord a) => Ord (Cofree f a);
deriving instance (Read (f (Cofree f a)), Read a) => Read (Cofree f a);
deriving instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a);
instance Functor f => Functor (Cofree f) where {
fmap f (x :< y) = f x :< (fmap f <$> y);
};
instance Functor f => Extend (Cofree f) where {
duplicate z@(x :< y) = z :< (duplicate <$> y);
};
instance Functor f => Comonad (Cofree f) where {
extract (x :< _) = x;
};
instance Applicative f => Applicative (Cofree f) where {
pure x = x :< pure (pure x);
(f :< fs) <*> (a :< as) = f a :< ((<*>) <$> fs <*> as);
(f :< fs) <* (_ :< as) = f :< ((<*) <$> fs <*> as);
(_ :< fs) *> (a :< as) = a :< ((*>) <$> fs <*> as);
};
instance ComonadHoist Cofree where {
cohoist (x :< y) = x :< (pure . cohoist $ extract y);
};
;
unfold :: Functor f => (b -> (a, f b)) -> b -> Cofree f a;
unfold f = uncurry (:<) . second (fmap $ unfold f) . f;
;
unreduceCofree :: Comonad w => (forall z. w z -> f z) -> w x -> Cofree f x;
unreduceCofree f x = extract x :< f (x =>> unreduceCofree f);
;
affectCofree :: Functor g => (forall z. (s, f z) -> g (s, z)) -> (s, Cofree f x) -> Cofree g (s, x);
affectCofree f (s, x :< y) = (s, x) :< w f (f (s, y)) where {
w :: Functor g => (forall z. (s, f z) -> g (s, z)) -> g (s, Cofree f x) -> g (Cofree g (s, x));
w f' x' = affectCofree f' <$> x';
};
;
newtype FreeT f m r = FreeT { runFreeT :: m (Either r (f (FreeT f m r))) };
instance (Functor f, Functor m) => Functor (FreeT f m) where {
fmap f (FreeT x) = FreeT ((f +++ fmap (fmap f)) <$> x);
};
instance (Functor f, Monad m) => Monad (FreeT f m) where {
return = FreeT . return . Left;
FreeT m >>= f = FreeT (m >>= either (runFreeT . f) (return . Right . fmap (>>= f)));
};
joinFreeT :: (Functor f, Monad m) => FreeT f m (FreeT f m x) -> FreeT f m x;
joinFreeT (FreeT x) = FreeT (x >>= either runFreeT (return . Right . fmap join));
instance (Functor f, Applicative m, Monad m) => Applicative (FreeT f m) where {
pure = return;
(<*>) = ap;
};
instance (Functor f, MonadPlus m) => MonadPlus (FreeT f m) where {
mzero = FreeT mzero;
mplus (FreeT x) (FreeT y) = FreeT (mplus x y);
};
instance (Functor f, Monad m, Alternative m) => Alternative (FreeT f m) where {
empty = FreeT empty;
FreeT x <|> FreeT y = FreeT (x <|> y);
};
instance Plus m => Plus (FreeT f m) where {
zero = FreeT zero;
plus (FreeT x) (FreeT y) = FreeT (plus x y);
};
instance MonadTrans (FreeT f) where {
lift = FreeT . liftM Left;
};
;
reduceFreeT :: Monad m => (forall z. f z -> m z) -> FreeT f m x -> m x;
reduceFreeT f (FreeT x) = x >>= either return (f >=> reduceFreeT f);
data CofreeT f w x = CofreeT (w x) (f (CofreeT f w x));
instance (Functor f, Functor w) => Functor (CofreeT f w) where {
fmap f (CofreeT x y) = CofreeT (f <$> x) (fmap f <$> y);
};
instance (Functor f, Extend w) => Extend (CofreeT f w) where {
duplicate (CofreeT x y) = CofreeT (x =>> flip CofreeT y) (duplicate <$> y);
};
instance (Functor f, Comonad w) => Comonad (CofreeT f w) where {
extract (CofreeT x _) = extract x;
};
instance ComonadTrans (CofreeT f) where {
lower (CofreeT x _) = x;
};
;
unreduceCofreeT :: Comonad w => (forall z. w z -> f z) -> w x -> CofreeT f w x;
unreduceCofreeT f x = CofreeT x (f (x =>> unreduceCofreeT f));
;
newtype Codensity f x = Codensity { runCodensity :: forall z. (x -> f z) -> f z };
instance Functor (Codensity f) where {
fmap f (Codensity x) = Codensity (\k -> x (k . f));
};
instance Monad (Codensity f) where {
return x = Codensity ($ x);
m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c));
};
instance Applicative (Codensity f) where {
pure x = Codensity ($ x);
(<*>) = ap;
};
instance Plus f => Alternative (Codensity f) where {
empty = Codensity (const zero);
Codensity x <|> Codensity y = Codensity (liftA2 plus x y);
};
instance Plus f => MonadPlus (Codensity f) where {
mzero = Codensity (const zero);
mplus (Codensity x) (Codensity y) = Codensity (liftA2 plus x y);
};
instance Plus f => Plus (Codensity f) where {
zero = mzero;
plus = mplus;
};
instance MonadTrans Codensity where {
lift x = Codensity (x >>=);
};
;
lowerCodensity :: Applicative f => Codensity f x -> f x;
lowerCodensity (Codensity x) = x pure;
;
data Density f x = forall z. Density (f z -> x) (f z);
instance Functor (Density f) where {
fmap f (Density x y) = Density (f . x) y;
};
instance Extend (Density f) where {
duplicate (Density f x) = Density (Density f) x;
};
instance Comonad (Density f) where {
extract (Density f x) = f x;
};
instance Applicative f => Applicative (Density f) where {
pure x = Density (const x) (pure ());
Density f x <*> Density a y = Density (\k -> f (fst <$> k) (a (snd <$> k))) (liftA2 (,) x y);
};
instance ComonadTrans Density where {
lower (Density f x) = x =>> f;
};
;
liftDensity :: Comonad w => w a -> Density w a;
liftDensity = Density extract;
newtype CodensityAskT w m x = CodensityAskT { runCodensityAskT :: forall z. w (m z) -> (x -> m z) -> m z };
;
newtype CodensityAsk w x = CodensityAsk { runCodensityAsk :: forall z. w z -> (x -> z) -> z };
instance Functor (CodensityAskT w m) where {
fmap f (CodensityAskT x) = CodensityAskT (\q k -> x q (k . f));
};
instance Monad (CodensityAskT w m) where {
return x = CodensityAskT (\_ f -> f x);
CodensityAskT m >>= f = CodensityAskT (\q k -> m q (\a -> runCodensityAskT (f a) q k));
};
instance Comonad w => MonadPlus (CodensityAskT w m) where {
mzero = CodensityAskT (\q _ -> extract q);
mplus (CodensityAskT f) (CodensityAskT g) = CodensityAskT $ flip (\y -> flip f y =<= flip g y);
};
instance Applicative (CodensityAskT w f) where {
pure = return;
(<*>) = ap;
};
instance Comonad w => Alternative (CodensityAskT w f) where {
empty = CodensityAskT (\q _ -> extract q);
CodensityAskT f <|> CodensityAskT g = CodensityAskT $ flip (\y -> flip f y =<= flip g y);
};
instance Comonad w => Plus (CodensityAskT w f) where {
zero = empty;
plus = (<|>);
};
instance MonadTrans (CodensityAskT w) where {
lift x = CodensityAskT (\_ f -> x >>= f);
};
instance Functor (CodensityAsk w) where {
fmap f (CodensityAsk x) = CodensityAsk (\q k -> x q (k . f));
};
instance Monad (CodensityAsk w) where {
return x = CodensityAsk (\_ f -> f x);
CodensityAsk m >>= f = CodensityAsk (\q k -> m q (\a -> runCodensityAsk (f a) q k));
};
instance Comonad w => MonadPlus (CodensityAsk w) where {
mzero = CodensityAsk (\q _ -> extract q);
mplus (CodensityAsk f) (CodensityAsk g) = CodensityAsk $ flip (\y -> flip f y =<= flip g y);
};
instance Applicative (CodensityAsk w) where {
pure = return;
(<*>) = ap;
};
instance Comonad w => Alternative (CodensityAsk w) where {
empty = CodensityAsk (\q _ -> extract q);
CodensityAsk f <|> CodensityAsk g = CodensityAsk $ flip (\y -> flip f y =<= flip g y);
};
instance Comonad w => Plus (CodensityAsk w) where {
zero = empty;
plus = (<|>);
};
;
peekCodensityAsk :: w x -> CodensityAsk w x -> x;
peekCodensityAsk x (CodensityAsk f) = f x id;
peekCodensityAskT :: Applicative m => w (m x) -> CodensityAskT w m x -> m x;
peekCodensityAskT x (CodensityAskT f) = f x pure;
lowerCodensityAskT :: (Plus w, Applicative m) => CodensityAskT w m x -> m x;
lowerCodensityAskT (CodensityAskT f) = f zero pure;
catchCodensityAsk :: w (CodensityAsk w x) -> CodensityAsk w x -> CodensityAsk w x;
catchCodensityAsk w (CodensityAsk f) = f w return;
catchCodensityAskT :: (Functor w, Monad m) => w (CodensityAskT w m x) -> CodensityAskT w m x -> CodensityAskT w m x;
catchCodensityAskT w (CodensityAskT f) = join . lift $ f (return <$> w) (return . return);
data DensityAskT p f x = forall z. DensityAskT (p z -> f z -> x) (f z);
;
type DensityAsk p = DensityAskT p Identity;
instance Functor (DensityAskT p f) where {
fmap f (DensityAskT x y) = DensityAskT (\q -> f . x q) y;
};
instance Plus p => Extend (DensityAskT p f) where {
duplicate (DensityAskT x y) = DensityAskT (\q z -> DensityAskT (\q' z' -> x (plus q q') z') z) y;
};
instance Plus p => Comonad (DensityAskT p f) where {
extract (DensityAskT x y) = x zero y;
};
instance Plus p => ComonadTrans (DensityAskT p) where {
lower (DensityAskT x y) = y =>> x zero;
};
liftDensityAsk :: Comonad w => w x -> DensityAskT p w x;
liftDensityAsk = DensityAskT $ const extract;
;
newtype CoT w m a = CoT { runCoT :: forall r. w (a -> m r) -> m r };
type Co w = CoT w Identity;
runCo :: Functor w => Co w a -> w (a -> r) -> r;
runCo m = runIdentity . runCoT m . fmap (fmap Identity);
instance Functor w => Functor (CoT w m) where {
fmap f (CoT w) = CoT (w . fmap (. f));
};
instance Comonad w => Applicative (CoT w m) where {
pure x = CoT (flip extract x);
f <*> x = f >>= flip fmap x;
};
instance Comonad w => Monad (CoT w m) where {
return x = CoT (flip extract x);
CoT k >>= f = CoT (k . extend (\w a -> runCoT (f a) w))
};
instance (Comonad w, Plus m) => Alternative (CoT w m) where {
empty = CoT (const zero);
CoT x <|> CoT y = CoT (liftA2 plus x y);
};
instance (Comonad w, Plus m) => MonadPlus (CoT w m) where {
mzero = CoT (const zero);
mplus (CoT x) (CoT y) = CoT (liftA2 plus x y);
};
instance Comonad w => MonadTrans (CoT w) where {
lift x = CoT (\z -> x >>= extract z);
};
liftCoT0 :: Comonad w => (forall a. w a -> s) -> CoT w m s;
liftCoT0 f = CoT (extract <*> f);
lowerCoT0 :: (Functor w, Applicative m) => CoT w m s -> w a -> m s;
lowerCoT0 (CoT m) = m . (pure <$);
lowerCo0 :: Functor w => Co w s -> w a -> s;
lowerCo0 (CoT m) = runIdentity . m . (return <$);
liftCoT1 :: (forall a. w a -> a) -> CoT w m ();
liftCoT1 f = CoT $ flip f ();
lowerCoT1 :: (Functor w, Applicative m) => CoT w m z -> w a -> m a;
lowerCoT1 (CoT m) = m . fmap (const . pure);
lowerCo1 :: Functor w => Co w z -> w a -> a;
lowerCo1 (CoT m) = runIdentity . m . fmap (const . return);
;
data Finalize x = Finalize;
;
data Initialize x;
instance Functor Finalize where {
fmap _ Finalize = Finalize;
};
instance Contravariant Finalize where {
contramap _ Finalize = Finalize;
};
instance Applicative Finalize where {
pure _ = Finalize;
Finalize <*> Finalize = Finalize;
};
instance Monad Finalize where {
return _ = Finalize;
Finalize >>= _ = Finalize;
};
instance Alternative Finalize where {
empty = Finalize;
Finalize <|> Finalize = Finalize;
};
instance MonadPlus Finalize where {
mzero = Finalize;
mplus Finalize Finalize = Finalize;
};
instance Monoid (Finalize x) where {
mempty = Finalize;
mappend Finalize Finalize = Finalize;
mconcat _ = Finalize;
};
instance Functor Initialize where {
fmap _ _ = undefined;
};
instance Contravariant Initialize where {
contramap _ _ = undefined;
};
instance Extend Initialize where {
duplicate _ = undefined;
};
instance Comonad Initialize where {
extract _ = undefined;
};
data Decompose :: (* -> *) -> (* -> *) -> * -> * where {
Decompose :: y z -> Decompose x y (x z);
};
instance ComonadHoist (Decompose f) where {
cohoist (Decompose a) = Decompose (pure $ extract a);
};
data Recompose :: ((* -> *) -> (* -> *) -> * -> *) -> (* -> *) -> * -> * where {
Recompose :: forall (w :: (* -> *) -> (* -> *) -> * -> *) (x :: * -> *) y z. w x y (x z) -> Recompose w y z;
};
instance Plus [] where {
zero = [];
plus = (++);
};
instance Plus Maybe where {
zero = empty;
plus = (<|>);
};
instance Plus Seq where {
zero = mempty;
plus = mappend;
};
instance Ord k => Plus (Map k) where {
zero = mempty;
plus = mappend;
};
instance Plus IntMap where {
zero = mempty;
plus = mappend;
};
instance (Functor m, Monad m) => Plus (MaybeT m) where {
zero = empty;
plus = (<|>);
};
instance (ArrowZero a, ArrowPlus a) => Plus (WrappedArrow a b) where {
zero = empty;
plus = (<|>);
};
instance (Monoid w, Functor m, MonadPlus m) => Plus (RWST r w s m) where {
zero = mzero;
plus = mplus;
};
instance Plus f => Plus (ReaderT x f) where {
zero = ReaderT (const zero);
plus (ReaderT x) (ReaderT y) = ReaderT (liftA2 plus x y);
};
instance Plus f => Plus (WriterT x f) where {
zero = WriterT zero;
plus (WriterT x) (WriterT y) = WriterT (plus x y);
};
instance MonadPlus m => Plus (StateT s m) where {
zero = mzero;
plus = mplus;
};
}