{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Action
-- Copyright   :  (C) 2012-14 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module Control.Lens.Action
  (
  -- * Composable Actions
    Action
  , act
  , acts
  , perform
  , performs
  , liftAct
  , (^!)
  , (^!!)
  , (^!?)

  -- * Indexed Actions
  , IndexedAction
  , iact
  , iperform
  , iperforms
  , (^@!)
  , (^@!!)
  , (^@!?)

  -- * Folds with Effects
  , MonadicFold
  , IndexedMonadicFold

  -- * Implementation Details
  , Acting
  , IndexedActing
  , Effective
  ) where

import Control.Comonad
import Control.Lens.Internal.Fold
import Control.Lens.Internal.Indexed
import Control.Lens.Type
import Control.Monad (liftM)
import Control.Monad.Trans.Class
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
import Data.Profunctor.Unsafe

import Control.Lens.Action.Internal
import Control.Lens.Action.Type

-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens

infixr 8 ^!, ^!!, ^@!, ^@!!, ^!?, ^@!?

-- | Used to evaluate an 'Action'.
type Acting m r s a = LensLike (Effect m r) s s a a

-- | Perform an 'Action'.
--
-- @
-- 'perform' ≡ 'flip' ('^!')
-- @
perform :: Monad m => Acting m a s a -> s -> m a
perform :: Acting m a s a -> s -> m a
perform Acting m a s a
l = Effect m a s -> m a
forall (m :: * -> *) r a. Effect m r a -> m r
getEffect (Effect m a s -> m a) -> (s -> Effect m a s) -> s -> m a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Acting m a s a
l (m a -> Effect m a a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect (m a -> Effect m a a) -> (a -> m a) -> a -> Effect m a a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return)
{-# INLINE perform #-}

-- | Perform an 'Action' and modify the result.
--
-- @
-- 'performs' :: 'Monad' m => 'Acting' m e s a -> (a -> e) -> s -> m e
-- @
performs :: (Profunctor p, Monad m) => Over p (Effect m e) s t a b -> p a e -> s -> m e
performs :: Over p (Effect m e) s t a b -> p a e -> s -> m e
performs Over p (Effect m e) s t a b
l p a e
f = Effect m e t -> m e
forall (m :: * -> *) r a. Effect m r a -> m r
getEffect (Effect m e t -> m e) -> (s -> Effect m e t) -> s -> m e
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Over p (Effect m e) s t a b
l ((e -> Effect m e b) -> p a e -> p a (Effect m e b)
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (m e -> Effect m e b
forall (m :: * -> *) r a. m r -> Effect m r a
Effect (m e -> Effect m e b) -> (e -> m e) -> e -> Effect m e b
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. e -> m e
forall (m :: * -> *) a. Monad m => a -> m a
return) p a e
f)
{-# INLINE performs #-}

-- | Perform an 'Action'.
--
-- >>> ["hello","world"]^!folded.act putStrLn
-- hello
-- world
(^!) :: Monad m => s -> Acting m a s a -> m a
s
a ^! :: s -> Acting m a s a -> m a
^! Acting m a s a
l = Effect m a s -> m a
forall (m :: * -> *) r a. Effect m r a -> m r
getEffect (Acting m a s a
l (m a -> Effect m a a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect (m a -> Effect m a a) -> (a -> m a) -> a -> Effect m a a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return) s
a)
{-# INLINE (^!) #-}

-- | Perform a 'MonadicFold' and collect all of the results in a list.
--
-- >>> ["ab","cd","ef"]^!!folded.acts
-- ["ace","acf","ade","adf","bce","bcf","bde","bdf"]
--
-- @
-- > [1,2]^!!folded.act (\i -> putStr (show i ++ ": ") >> getLine).each.to succ
-- 1: aa
-- 2: bb
-- "bbcc"
-- @
(^!!) :: Monad m => s -> Acting m [a] s a -> m [a]
s
a ^!! :: s -> Acting m [a] s a -> m [a]
^!! Acting m [a] s a
l = Effect m [a] s -> m [a]
forall (m :: * -> *) r a. Effect m r a -> m r
getEffect (Acting m [a] s a
l (m [a] -> Effect m [a] a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect (m [a] -> Effect m [a] a) -> (a -> m [a]) -> a -> Effect m [a] a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> (a -> [a]) -> a -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return) s
a)
{-# INLINE (^!!) #-}

-- | Perform a 'MonadicFold' and collect the leftmost result.
--
-- /Note:/ this still causes all effects for all elements.
--
-- >>> [Just 1, Just 2, Just 3]^!?folded.acts
-- Just (Just 1)
-- >>> [Just 1, Nothing]^!?folded.acts
-- Nothing
(^!?) :: Monad m => s -> Acting m (Leftmost a) s a -> m (Maybe a)
s
a ^!? :: s -> Acting m (Leftmost a) s a -> m (Maybe a)
^!?  Acting m (Leftmost a) s a
l = (Leftmost a -> Maybe a) -> m (Leftmost a) -> m (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Leftmost a -> Maybe a
forall a. Leftmost a -> Maybe a
getLeftmost (m (Leftmost a) -> m (Maybe a))
-> (Effect m (Leftmost a) s -> m (Leftmost a))
-> Effect m (Leftmost a) s
-> m (Maybe a)
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# Effect m (Leftmost a) s -> m (Leftmost a)
forall (m :: * -> *) r a. Effect m r a -> m r
getEffect (Effect m (Leftmost a) s -> m (Maybe a))
-> Effect m (Leftmost a) s -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Acting m (Leftmost a) s a
l (m (Leftmost a) -> Effect m (Leftmost a) a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect (m (Leftmost a) -> Effect m (Leftmost a) a)
-> (a -> m (Leftmost a)) -> a -> Effect m (Leftmost a) a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Leftmost a -> m (Leftmost a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Leftmost a -> m (Leftmost a))
-> (a -> Leftmost a) -> a -> m (Leftmost a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Leftmost a
forall a. a -> Leftmost a
LLeaf) s
a
{-# INLINE (^!?) #-}

-- | Construct an 'Action' from a monadic side-effect.
--
-- >>> ["hello","world"]^!folded.act (\x -> [x,x ++ "!"])
-- ["helloworld","helloworld!","hello!world","hello!world!"]
--
-- @
-- 'act' :: 'Monad' m => (s -> m a) -> 'Action' m s a
-- 'act' sma afb a = 'effective' (sma a '>>=' 'ineffective' '.' afb)
-- @
act :: Monad m => (s -> m a) -> IndexPreservingAction m s a
act :: (s -> m a) -> IndexPreservingAction m s a
act s -> m a
sma p a (f a)
pafb = (Corep p s -> f s) -> p s (f s)
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate ((Corep p s -> f s) -> p s (f s))
-> (Corep p s -> f s) -> p s (f s)
forall a b. (a -> b) -> a -> b
$ \Corep p s
ws -> m r -> f s
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
m r -> f a
effective (m r -> f s) -> m r -> f s
forall a b. (a -> b) -> a -> b
$ do
   a
a <- s -> m a
sma (Corep p s -> s
forall (w :: * -> *) a. Comonad w => w a -> a
extract Corep p s
ws)
   f a -> m r
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
f a -> m r
ineffective (p a (f a) -> Corep p a -> f a
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve p a (f a)
pafb (a
a a -> Corep p s -> Corep p a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Corep p s
ws))
{-# INLINE act #-}

-- | A self-running 'Action', analogous to 'Control.Monad.join'.
--
-- @
-- 'acts' ≡ 'act' 'id'
-- @
--
-- >>> (1,"hello")^!_2.acts.to succ
-- "ifmmp"
--
-- @
-- > (1,getLine)^!!_2.acts.folded.to succ
-- aa
-- "bb"
-- @
acts :: IndexPreservingAction m (m a) a
acts :: p a (f a) -> p (m a) (f (m a))
acts = (m a -> m a) -> IndexPreservingAction m (m a) a
forall (m :: * -> *) s a.
Monad m =>
(s -> m a) -> IndexPreservingAction m s a
act m a -> m a
forall a. a -> a
id
{-# INLINE acts #-}

-- | Apply a 'Monad' transformer to an 'Action'.
liftAct :: (MonadTrans trans, Monad m) => Acting m a s a -> IndexPreservingAction (trans m) s a
liftAct :: Acting m a s a -> IndexPreservingAction (trans m) s a
liftAct Acting m a s a
l = (s -> trans m a) -> IndexPreservingAction (trans m) s a
forall (m :: * -> *) s a.
Monad m =>
(s -> m a) -> IndexPreservingAction m s a
act (m a -> trans m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> trans m a) -> (s -> m a) -> s -> trans m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acting m a s a -> s -> m a
forall (m :: * -> *) a s. Monad m => Acting m a s a -> s -> m a
perform Acting m a s a
l)
{-# INLINE liftAct #-}

-----------------------------------------------------------------------------
-- Indexed Actions
----------------------------------------------------------------------------

-- | Used to evaluate an 'IndexedAction'.
type IndexedActing i m r s a = Over (Indexed i) (Effect m r) s s a a

-- | Perform an 'IndexedAction'.
--
-- @
-- 'iperform' ≡ 'flip' ('^@!')
-- @
iperform :: Monad m => IndexedActing i m (i, a) s a -> s -> m (i, a)
iperform :: IndexedActing i m (i, a) s a -> s -> m (i, a)
iperform IndexedActing i m (i, a) s a
l = Effect m (i, a) s -> m (i, a)
forall (m :: * -> *) r a. Effect m r a -> m r
getEffect (Effect m (i, a) s -> m (i, a))
-> (s -> Effect m (i, a) s) -> s -> m (i, a)
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. IndexedActing i m (i, a) s a
l ((i -> a -> Effect m (i, a) a) -> Indexed i a (Effect m (i, a) a)
forall i a b. (i -> a -> b) -> Indexed i a b
Indexed ((i -> a -> Effect m (i, a) a) -> Indexed i a (Effect m (i, a) a))
-> (i -> a -> Effect m (i, a) a) -> Indexed i a (Effect m (i, a) a)
forall a b. (a -> b) -> a -> b
$ \i
i a
a -> m (i, a) -> Effect m (i, a) a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect ((i, a) -> m (i, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (i
i, a
a)))
{-# INLINE iperform #-}

-- | Perform an 'IndexedAction' and modify the result.
iperforms :: Monad m => IndexedActing i m e s a -> (i -> a -> e) -> s -> m e
iperforms :: IndexedActing i m e s a -> (i -> a -> e) -> s -> m e
iperforms IndexedActing i m e s a
l = IndexedActing i m e s a -> Indexed i a e -> s -> m e
forall (p :: * -> * -> *) (m :: * -> *) e s t a b.
(Profunctor p, Monad m) =>
Over p (Effect m e) s t a b -> p a e -> s -> m e
performs IndexedActing i m e s a
l (Indexed i a e -> s -> m e)
-> ((i -> a -> e) -> Indexed i a e) -> (i -> a -> e) -> s -> m e
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# (i -> a -> e) -> Indexed i a e
forall i a b. (i -> a -> b) -> Indexed i a b
Indexed
{-# INLINE iperforms #-}

-- | Perform an 'IndexedAction'.
(^@!) :: Monad m => s -> IndexedActing i m (i, a) s a -> m (i, a)
s
s ^@! :: s -> IndexedActing i m (i, a) s a -> m (i, a)
^@! IndexedActing i m (i, a) s a
l = Effect m (i, a) s -> m (i, a)
forall (m :: * -> *) r a. Effect m r a -> m r
getEffect (IndexedActing i m (i, a) s a
l ((i -> a -> Effect m (i, a) a) -> Indexed i a (Effect m (i, a) a)
forall i a b. (i -> a -> b) -> Indexed i a b
Indexed ((i -> a -> Effect m (i, a) a) -> Indexed i a (Effect m (i, a) a))
-> (i -> a -> Effect m (i, a) a) -> Indexed i a (Effect m (i, a) a)
forall a b. (a -> b) -> a -> b
$ \i
i a
a -> m (i, a) -> Effect m (i, a) a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect ((i, a) -> m (i, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (i
i, a
a))) s
s)
{-# INLINE (^@!) #-}

-- | Obtain a list of all of the results of an 'IndexedMonadicFold'.
(^@!!) :: Monad m => s -> IndexedActing i m [(i, a)] s a -> m [(i, a)]
s
s ^@!! :: s -> IndexedActing i m [(i, a)] s a -> m [(i, a)]
^@!! IndexedActing i m [(i, a)] s a
l = Effect m [(i, a)] s -> m [(i, a)]
forall (m :: * -> *) r a. Effect m r a -> m r
getEffect (IndexedActing i m [(i, a)] s a
l ((i -> a -> Effect m [(i, a)] a)
-> Indexed i a (Effect m [(i, a)] a)
forall i a b. (i -> a -> b) -> Indexed i a b
Indexed ((i -> a -> Effect m [(i, a)] a)
 -> Indexed i a (Effect m [(i, a)] a))
-> (i -> a -> Effect m [(i, a)] a)
-> Indexed i a (Effect m [(i, a)] a)
forall a b. (a -> b) -> a -> b
$ \i
i a
a -> m [(i, a)] -> Effect m [(i, a)] a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect ([(i, a)] -> m [(i, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(i
i, a
a)])) s
s)
{-# INLINE (^@!!) #-}

-- | Perform an 'IndexedMonadicFold' and collect the 'Leftmost' result.
--
-- /Note:/ this still causes all effects for all elements.
(^@!?) :: Monad m => s -> IndexedActing i m (Leftmost (i, a)) s a -> m (Maybe (i, a))
s
a ^@!? :: s -> IndexedActing i m (Leftmost (i, a)) s a -> m (Maybe (i, a))
^@!?  IndexedActing i m (Leftmost (i, a)) s a
l = (Leftmost (i, a) -> Maybe (i, a))
-> m (Leftmost (i, a)) -> m (Maybe (i, a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Leftmost (i, a) -> Maybe (i, a)
forall a. Leftmost a -> Maybe a
getLeftmost (m (Leftmost (i, a)) -> m (Maybe (i, a)))
-> (Effect m (Leftmost (i, a)) s -> m (Leftmost (i, a)))
-> Effect m (Leftmost (i, a)) s
-> m (Maybe (i, a))
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# Effect m (Leftmost (i, a)) s -> m (Leftmost (i, a))
forall (m :: * -> *) r a. Effect m r a -> m r
getEffect (Effect m (Leftmost (i, a)) s -> m (Maybe (i, a)))
-> Effect m (Leftmost (i, a)) s -> m (Maybe (i, a))
forall a b. (a -> b) -> a -> b
$ IndexedActing i m (Leftmost (i, a)) s a
l ((i -> a -> Effect m (Leftmost (i, a)) a)
-> Indexed i a (Effect m (Leftmost (i, a)) a)
forall i a b. (i -> a -> b) -> Indexed i a b
Indexed ((i -> a -> Effect m (Leftmost (i, a)) a)
 -> Indexed i a (Effect m (Leftmost (i, a)) a))
-> (i -> a -> Effect m (Leftmost (i, a)) a)
-> Indexed i a (Effect m (Leftmost (i, a)) a)
forall a b. (a -> b) -> a -> b
$ \i
i -> m (Leftmost (i, a)) -> Effect m (Leftmost (i, a)) a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect (m (Leftmost (i, a)) -> Effect m (Leftmost (i, a)) a)
-> (a -> m (Leftmost (i, a))) -> a -> Effect m (Leftmost (i, a)) a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Leftmost (i, a) -> m (Leftmost (i, a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Leftmost (i, a) -> m (Leftmost (i, a)))
-> (a -> Leftmost (i, a)) -> a -> m (Leftmost (i, a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i, a) -> Leftmost (i, a)
forall a. a -> Leftmost a
LLeaf ((i, a) -> Leftmost (i, a))
-> (a -> (i, a)) -> a -> Leftmost (i, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) i
i) s
a
{-# INLINE (^@!?) #-}

-- | Construct an 'IndexedAction' from a monadic side-effect.
iact :: Monad m => (s -> m (i, a)) -> IndexedAction i m s a
iact :: (s -> m (i, a)) -> IndexedAction i m s a
iact s -> m (i, a)
smia p a (f a)
iafb s
s = m r -> f s
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
m r -> f a
effective (m r -> f s) -> m r -> f s
forall a b. (a -> b) -> a -> b
$ do
  (i
i, a
a) <- s -> m (i, a)
smia s
s
  f a -> m r
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
f a -> m r
ineffective (p a (f a) -> i -> a -> f a
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p a (f a)
iafb i
i a
a)
{-# INLINE iact #-}