Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

181 lines (157 sloc) 5.28 kb
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Lens.Action
-- Copyright : (C) 2012-13 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.Action
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.Unsafe
-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
infixr 8 ^!, ^!!, ^@!, ^@!!, ^!?, ^@!?
-- | Used to evaluate an 'Action'.
type Acting m r s t a b = LensLike (Effect m r) s t a b
-- | Perform an 'Action'.
--
-- @
-- 'perform' ≡ 'flip' ('^!')
-- @
perform :: Monad m => Acting m a s t a b -> s -> m a
perform l = getEffect #. l (Effect #. return)
{-# INLINE perform #-}
-- | Perform an 'Action' and modify the result.
--
-- @
-- 'performs' :: 'Monad' m => 'Acting' m e s t a b -> (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 l f = getEffect #. l (rmap (Effect #. return) f)
{-# INLINE performs #-}
-- | Perform an 'Action'.
--
-- >>> ["hello","world"]^!folded.act putStrLn
-- hello
-- world
(^!) :: Monad m => s -> Acting m a s t a b -> m a
a ^! l = getEffect (l (Effect #. return) a)
{-# INLINE (^!) #-}
-- | Perform a 'MonadicFold' and collect all of the results in a list.
(^!!) :: Monad m => s -> Acting m [a] s t a b -> m [a]
a ^!! l = getEffect (l (Effect #. return . return) a)
{-# INLINE (^!!) #-}
-- | Perform a 'MonadicFold' and collect the leftmost result.
--
-- /Note:/ this still causes all effects for all elements.
(^!?) :: Monad m => s -> Acting m (Leftmost a) s t a b -> m (Maybe a)
a ^!? l = liftM getLeftmost .# getEffect $ l (Effect #. return . LLeaf) 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 sma pafb = cotabulate $ \ws -> effective $ do
a <- sma (extract ws)
ineffective (corep pafb (a <$ ws))
{-# INLINE act #-}
-- | A self-running 'Action', analogous to 'Control.Monad.join'.
--
-- @
-- 'acts' ≡ 'act' 'id'
-- @
--
-- >>> (1,"hello")^!_2.acts.to succ
-- "ifmmp"
acts :: Action m (m a) a
acts = act id
{-# INLINE acts #-}
-- | Apply a 'Monad' transformer to an 'Action'.
liftAct :: (MonadTrans trans, Monad m) => Acting m a s t a b -> Action (trans m) s a
liftAct l = act (lift . perform l)
{-# INLINE liftAct #-}
-----------------------------------------------------------------------------
-- Indexed Actions
----------------------------------------------------------------------------
-- | Used to evaluate an 'IndexedAction'.
type IndexedActing i m r s t a b = Over (Indexed i) (Effect m r) s t a b
-- | Perform an 'IndexedAction'.
--
-- @
-- 'iperform' ≡ 'flip' ('^@!')
-- @
iperform :: Monad m => IndexedActing i m (i, a) s t a b -> s -> m (i, a)
iperform l = getEffect #. l (Indexed $ \i a -> Effect (return (i, a)))
{-# INLINE iperform #-}
-- | Perform an 'IndexedAction' and modify the result.
iperforms :: Monad m => IndexedActing i m e s t a b -> (i -> a -> e) -> s -> m e
iperforms l = performs l .# Indexed
{-# INLINE iperforms #-}
-- | Perform an 'IndexedAction'.
(^@!) :: Monad m => s -> IndexedActing i m (i, a) s t a b -> m (i, a)
s ^@! l = getEffect (l (Indexed $ \i a -> Effect (return (i, a))) s)
{-# INLINE (^@!) #-}
-- | Obtain a list of all of the results of an 'IndexedMonadicFold'.
(^@!!) :: Monad m => s -> IndexedActing i m [(i, a)] s t a b -> m [(i, a)]
s ^@!! l = getEffect (l (Indexed $ \i a -> Effect (return [(i, a)])) 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 t a b -> m (Maybe (i, a))
a ^@!? l = liftM getLeftmost .# getEffect $ l (Indexed $ \i -> Effect #. return . LLeaf . (,) i) a
{-# INLINE (^@!?) #-}
-- | Construct an 'IndexedAction' from a monadic side-effect.
iact :: Monad m => (s -> m (i, a)) -> IndexedAction i m s a
iact smia iafb s = effective $ do
(i, a) <- smia s
ineffective (indexed iafb i a)
{-# INLINE iact #-}
Jump to Line
Something went wrong with that request. Please try again.