{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE RankNTypes             #-}

-- | This module exposes the SieveTrans class and some Sieve transformers based
-- on usual Reader and Writer

module Data.Profunctor.Trans where

import Control.Arrow
import Control.Monad.IO.Class
import Data.Bifunctor.Tannen
import Data.Profunctor
import Data.Profunctor.Cayley

import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.Writer.Strict as W


-- | A general version of 'Sieve' that allows mapping and recursively reaching
-- the sieve
class SieveTrans f cat | cat -> f where
  liftSieve :: (a -> f b) -> cat a b
  mapSieve :: ((a -> f b) -> (a' -> f b')) -> cat a b -> cat a' b'

-- | Just an alias
type HasKleisli = SieveTrans

-- | Just an alias
liftKleisli :: (HasKleisli m eff) => (a -> m b) -> eff a b
liftKleisli :: (a -> m b) -> eff a b
liftKleisli = (a -> m b) -> eff a b
forall (f :: * -> *) (cat :: * -> * -> *) a b.
SieveTrans f cat =>
(a -> f b) -> cat a b
liftSieve
{-# INLINE liftKleisli #-}

-- | Just an alias
mapKleisli :: (HasKleisli m eff)
           => ((a -> m b) -> (a' -> m b')) -> eff a b -> eff a' b'
mapKleisli :: ((a -> m b) -> a' -> m b') -> eff a b -> eff a' b'
mapKleisli = ((a -> m b) -> a' -> m b') -> eff a b -> eff a' b'
forall (f :: * -> *) (cat :: * -> * -> *) a b a' b'.
SieveTrans f cat =>
((a -> f b) -> a' -> f b') -> cat a b -> cat a' b'
mapSieve
{-# INLINE mapKleisli #-}

instance SieveTrans f (Star f) where
  liftSieve :: (a -> f b) -> Star f a b
liftSieve = (a -> f b) -> Star f a b
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star
  mapSieve :: ((a -> f b) -> a' -> f b') -> Star f a b -> Star f a' b'
mapSieve (a -> f b) -> a' -> f b'
f (Star a -> f b
m) = (a' -> f b') -> Star f a' b'
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a' -> f b') -> Star f a' b') -> (a' -> f b') -> Star f a' b'
forall a b. (a -> b) -> a -> b
$ (a -> f b) -> a' -> f b'
f a -> f b
m

instance SieveTrans m (Kleisli m) where
  liftSieve :: (a -> m b) -> Kleisli m a b
liftSieve = (a -> m b) -> Kleisli m a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli
  mapSieve :: ((a -> m b) -> a' -> m b') -> Kleisli m a b -> Kleisli m a' b'
mapSieve (a -> m b) -> a' -> m b'
f (Kleisli a -> m b
m) = (a' -> m b') -> Kleisli m a' b'
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((a' -> m b') -> Kleisli m a' b')
-> (a' -> m b') -> Kleisli m a' b'
forall a b. (a -> b) -> a -> b
$ (a -> m b) -> a' -> m b'
f a -> m b
m

instance (SieveTrans f cat, Applicative f')
  => SieveTrans f (Cayley f' cat) where
  liftSieve :: (a -> f b) -> Cayley f' cat a b
liftSieve = f' (cat a b) -> Cayley f' cat a b
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Cayley f p a b
Cayley (f' (cat a b) -> Cayley f' cat a b)
-> ((a -> f b) -> f' (cat a b)) -> (a -> f b) -> Cayley f' cat a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. cat a b -> f' (cat a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (cat a b -> f' (cat a b))
-> ((a -> f b) -> cat a b) -> (a -> f b) -> f' (cat a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> cat a b
forall (f :: * -> *) (cat :: * -> * -> *) a b.
SieveTrans f cat =>
(a -> f b) -> cat a b
liftSieve
  {-# INLINE liftSieve #-}
  mapSieve :: ((a -> f b) -> a' -> f b')
-> Cayley f' cat a b -> Cayley f' cat a' b'
mapSieve (a -> f b) -> a' -> f b'
f (Cayley f' (cat a b)
app) = f' (cat a' b') -> Cayley f' cat a' b'
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Cayley f p a b
Cayley (f' (cat a' b') -> Cayley f' cat a' b')
-> f' (cat a' b') -> Cayley f' cat a' b'
forall a b. (a -> b) -> a -> b
$ ((a -> f b) -> a' -> f b') -> cat a b -> cat a' b'
forall (f :: * -> *) (cat :: * -> * -> *) a b a' b'.
SieveTrans f cat =>
((a -> f b) -> a' -> f b') -> cat a b -> cat a' b'
mapSieve (a -> f b) -> a' -> f b'
f (cat a b -> cat a' b') -> f' (cat a b) -> f' (cat a' b')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f' (cat a b)
app
  {-# INLINE mapSieve #-}

instance (SieveTrans f cat, Applicative f)
  => SieveTrans f (Tannen f cat) where
  liftSieve :: (a -> f b) -> Tannen f cat a b
liftSieve = f (cat a b) -> Tannen f cat a b
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Tannen f p a b
Tannen (f (cat a b) -> Tannen f cat a b)
-> ((a -> f b) -> f (cat a b)) -> (a -> f b) -> Tannen f cat a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. cat a b -> f (cat a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (cat a b -> f (cat a b))
-> ((a -> f b) -> cat a b) -> (a -> f b) -> f (cat a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> cat a b
forall (f :: * -> *) (cat :: * -> * -> *) a b.
SieveTrans f cat =>
(a -> f b) -> cat a b
liftSieve
  {-# INLINE liftSieve #-}
  mapSieve :: ((a -> f b) -> a' -> f b')
-> Tannen f cat a b -> Tannen f cat a' b'
mapSieve (a -> f b) -> a' -> f b'
f (Tannen f (cat a b)
app) = f (cat a' b') -> Tannen f cat a' b'
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Tannen f p a b
Tannen (f (cat a' b') -> Tannen f cat a' b')
-> f (cat a' b') -> Tannen f cat a' b'
forall a b. (a -> b) -> a -> b
$ ((a -> f b) -> a' -> f b') -> cat a b -> cat a' b'
forall (f :: * -> *) (cat :: * -> * -> *) a b a' b'.
SieveTrans f cat =>
((a -> f b) -> a' -> f b') -> cat a b -> cat a' b'
mapSieve (a -> f b) -> a' -> f b'
f (cat a b -> cat a' b') -> f (cat a b) -> f (cat a' b')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (cat a b)
app
  {-# INLINE mapSieve #-}

type HasKleisliIO m eff = (HasKleisli m eff, MonadIO m)

-- | When you want to lift some IO action in a Sieve of any MonadIO
liftKleisliIO :: (HasKleisliIO m eff) => (a -> IO b) -> eff a b
liftKleisliIO :: (a -> IO b) -> eff a b
liftKleisliIO a -> IO b
f = (a -> m b) -> eff a b
forall (m :: * -> *) (eff :: * -> * -> *) a b.
HasKleisli m eff =>
(a -> m b) -> eff a b
liftKleisli ((a -> m b) -> eff a b) -> (a -> m b) -> eff a b
forall a b. (a -> b) -> a -> b
$ IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> (a -> IO b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO b
f
{-# INLINE liftKleisliIO #-}

-- | An alias to make signatures more readable
type (~>) = Cayley
infixr 1 ~>  -- To be of a lower precedence than (:->)

type Reader r = R.Reader r
type Writer w = W.Writer w

fmapping :: (Functor f) => f t -> (t -> eff a b) -> (f ~> eff) a b
fmapping :: f t -> (t -> eff a b) -> (~>) f eff a b
fmapping f t
a t -> eff a b
f = f (eff a b) -> (~>) f eff a b
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Cayley f p a b
Cayley (f (eff a b) -> (~>) f eff a b) -> f (eff a b) -> (~>) f eff a b
forall a b. (a -> b) -> a -> b
$ (t -> eff a b) -> f t -> f (eff a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> eff a b
f f t
a
{-# INLINE fmapping #-}

-- | mapCayley in profunctors maps the functor. mapCayleyEff maps the effect in
-- it.
mapCayleyEff :: (Functor f)
             => (eff a b -> eff' a' b')
             -> (f ~> eff) a b
             -> (f ~> eff') a' b'
mapCayleyEff :: (eff a b -> eff' a' b') -> (~>) f eff a b -> (~>) f eff' a' b'
mapCayleyEff eff a b -> eff' a' b'
f (Cayley f (eff a b)
eff) = f (eff' a' b') -> (~>) f eff' a' b'
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Cayley f p a b
Cayley (f (eff' a' b') -> (~>) f eff' a' b')
-> f (eff' a' b') -> (~>) f eff' a' b'
forall a b. (a -> b) -> a -> b
$ (eff a b -> eff' a' b') -> f (eff a b) -> f (eff' a' b')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap eff a b -> eff' a' b'
f f (eff a b)
eff
{-# INLINE mapCayleyEff #-}

reading :: (t -> eff a b) -> (Reader t ~> eff) a b
reading :: (t -> eff a b) -> (~>) (Reader t) eff a b
reading t -> eff a b
f = ReaderT t Identity (eff a b) -> (~>) (Reader t) eff a b
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Cayley f p a b
Cayley (ReaderT t Identity (eff a b) -> (~>) (Reader t) eff a b)
-> ReaderT t Identity (eff a b) -> (~>) (Reader t) eff a b
forall a b. (a -> b) -> a -> b
$ (t -> eff a b) -> ReaderT t Identity (eff a b)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
R.reader ((t -> eff a b) -> ReaderT t Identity (eff a b))
-> (t -> eff a b) -> ReaderT t Identity (eff a b)
forall a b. (a -> b) -> a -> b
$ t -> eff a b
f
{-# INLINE reading #-}

mapReader :: (t' -> eff a b -> (t, eff' a' b'))
          -> (Reader t ~> eff) a b
          -> (Reader t' ~> eff') a' b'
mapReader :: (t' -> eff a b -> (t, eff' a' b'))
-> (~>) (Reader t) eff a b -> (~>) (Reader t') eff' a' b'
mapReader t' -> eff a b -> (t, eff' a' b')
f (Cayley Reader t (eff a b)
eff) = ReaderT t' Identity (eff' a' b') -> (~>) (Reader t') eff' a' b'
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Cayley f p a b
Cayley ((t' -> eff' a' b') -> ReaderT t' Identity (eff' a' b')
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
R.reader ((t' -> eff' a' b') -> ReaderT t' Identity (eff' a' b'))
-> (t' -> eff' a' b') -> ReaderT t' Identity (eff' a' b')
forall a b. (a -> b) -> a -> b
$ \t'
t' ->
  let (t
t,eff' a' b'
eff') = t' -> eff a b -> (t, eff' a' b')
f t'
t' (eff a b -> (t, eff' a' b')) -> eff a b -> (t, eff' a' b')
forall a b. (a -> b) -> a -> b
$ Reader t (eff a b) -> t -> eff a b
forall r a. Reader r a -> r -> a
R.runReader Reader t (eff a b)
eff t
t
  in eff' a' b'
eff')
{-# INLINE mapReader #-}

mapReader_ :: (t -> eff a b -> eff' a' b')
           -> (Reader t ~> eff) a b
           -> (Reader t ~> eff') a' b'
mapReader_ :: (t -> eff a b -> eff' a' b')
-> (~>) (Reader t) eff a b -> (~>) (Reader t) eff' a' b'
mapReader_ t -> eff a b -> eff' a' b'
f (Cayley Reader t (eff a b)
eff) = ReaderT t Identity (eff' a' b') -> (~>) (Reader t) eff' a' b'
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Cayley f p a b
Cayley ((t -> eff' a' b') -> ReaderT t Identity (eff' a' b')
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
R.reader ((t -> eff' a' b') -> ReaderT t Identity (eff' a' b'))
-> (t -> eff' a' b') -> ReaderT t Identity (eff' a' b')
forall a b. (a -> b) -> a -> b
$ \t
x -> t -> eff a b -> eff' a' b'
f t
x (eff a b -> eff' a' b') -> eff a b -> eff' a' b'
forall a b. (a -> b) -> a -> b
$ Reader t (eff a b) -> t -> eff a b
forall r a. Reader r a -> r -> a
R.runReader Reader t (eff a b)
eff t
x)
{-# INLINE mapReader_ #-}

runReader :: t -> (Reader t ~> eff) a b -> eff a b
runReader :: t -> (~>) (Reader t) eff a b -> eff a b
runReader t
t (Cayley Reader t (eff a b)
f) = Reader t (eff a b) -> t -> eff a b
forall r a. Reader r a -> r -> a
R.runReader Reader t (eff a b)
f t
t
{-# INLINE runReader #-}

writing :: w -> eff :-> (Writer w ~> eff)
writing :: w -> eff :-> (Writer w ~> eff)
writing w
w eff a b
eff = WriterT w Identity (eff a b) -> Cayley (Writer w) eff a b
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Cayley f p a b
Cayley (WriterT w Identity (eff a b) -> Cayley (Writer w) eff a b)
-> WriterT w Identity (eff a b) -> Cayley (Writer w) eff a b
forall a b. (a -> b) -> a -> b
$ (eff a b, w) -> WriterT w Identity (eff a b)
forall (m :: * -> *) a w. Monad m => (a, w) -> WriterT w m a
W.writer (eff a b
eff, w
w)
{-# INLINE writing #-}

mapWriter :: (w -> eff a b -> (w',eff' a' b'))
          -> (Writer w ~> eff) a b
          -> (Writer w' ~> eff') a' b'
mapWriter :: (w -> eff a b -> (w', eff' a' b'))
-> (~>) (Writer w) eff a b -> (~>) (Writer w') eff' a' b'
mapWriter w -> eff a b -> (w', eff' a' b')
f (Cayley Writer w (eff a b)
act) = WriterT w' Identity (eff' a' b') -> (~>) (Writer w') eff' a' b'
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Cayley f p a b
Cayley (WriterT w' Identity (eff' a' b') -> (~>) (Writer w') eff' a' b')
-> WriterT w' Identity (eff' a' b') -> (~>) (Writer w') eff' a' b'
forall a b. (a -> b) -> a -> b
$ case Writer w (eff a b) -> (eff a b, w)
forall w a. Writer w a -> (a, w)
W.runWriter Writer w (eff a b)
act of
  (eff a b
eff,w
w) -> (eff' a' b', w') -> WriterT w' Identity (eff' a' b')
forall (m :: * -> *) a w. Monad m => (a, w) -> WriterT w m a
W.writer ((eff' a' b', w') -> WriterT w' Identity (eff' a' b'))
-> (eff' a' b', w') -> WriterT w' Identity (eff' a' b')
forall a b. (a -> b) -> a -> b
$ (w', eff' a' b') -> (eff' a' b', w')
forall a b. (a, b) -> (b, a)
swap ((w', eff' a' b') -> (eff' a' b', w'))
-> (w', eff' a' b') -> (eff' a' b', w')
forall a b. (a -> b) -> a -> b
$ w -> eff a b -> (w', eff' a' b')
f w
w eff a b
eff
{-# INLINE mapWriter #-}

mapWriter_ :: (w -> eff a b -> eff' a' b')
           -> (Writer w ~> eff) a b
           -> (Writer w ~> eff') a' b'
mapWriter_ :: (w -> eff a b -> eff' a' b')
-> (~>) (Writer w) eff a b -> (~>) (Writer w) eff' a' b'
mapWriter_ w -> eff a b -> eff' a' b'
f = (w -> eff a b -> (w, eff' a' b'))
-> (~>) (Writer w) eff a b -> (~>) (Writer w) eff' a' b'
forall w (eff :: * -> * -> *) a b w' (eff' :: * -> * -> *) a' b'.
(w -> eff a b -> (w', eff' a' b'))
-> (~>) (Writer w) eff a b -> (~>) (Writer w') eff' a' b'
mapWriter (\w
w eff a b
e -> (w
w,w -> eff a b -> eff' a' b'
f w
w eff a b
e))
{-# INLINE mapWriter_ #-}

runWriter :: (Writer w ~> eff) a b -> (w, eff a b)
runWriter :: (~>) (Writer w) eff a b -> (w, eff a b)
runWriter (Cayley Writer w (eff a b)
eff) = (eff a b, w) -> (w, eff a b)
forall a b. (a, b) -> (b, a)
swap ((eff a b, w) -> (w, eff a b)) -> (eff a b, w) -> (w, eff a b)
forall a b. (a -> b) -> a -> b
$ Writer w (eff a b) -> (eff a b, w)
forall w a. Writer w a -> (a, w)
W.runWriter Writer w (eff a b)
eff
{-# INLINE runWriter #-}

runWriter_ :: (Writer w ~> eff) a b -> eff a b
runWriter_ :: (~>) (Writer w) eff a b -> eff a b
runWriter_ (Cayley Writer w (eff a b)
eff) = (eff a b, w) -> eff a b
forall a b. (a, b) -> a
fst ((eff a b, w) -> eff a b) -> (eff a b, w) -> eff a b
forall a b. (a -> b) -> a -> b
$ Writer w (eff a b) -> (eff a b, w)
forall w a. Writer w a -> (a, w)
W.runWriter Writer w (eff a b)
eff
{-# INLINE runWriter_ #-}

swap :: (a,b) -> (b,a)
swap :: (a, b) -> (b, a)
swap (a
a,b
b) = (b
b,a
a)
{-# INLINE swap #-}

returning :: (Arrow eff) => b -> eff a b
returning :: b -> eff a b
returning = (a -> b) -> eff a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> b) -> eff a b) -> (b -> a -> b) -> b -> eff a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a -> b
forall a b. a -> b -> a
const
{-# INLINE returning #-}

-- | Just a flipped variant of runKleisli
perform :: a -> Kleisli m a b -> m b
perform :: a -> Kleisli m a b -> m b
perform = (Kleisli m a b -> a -> m b) -> a -> Kleisli m a b -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Kleisli m a b -> a -> m b
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli
{-# INLINE perform #-}