{-# 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.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 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 l = getEffect #. l (Effect #. 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 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 a -> m a a ^! l = getEffect (l (Effect #. return) 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] 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. -- -- >>> [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) 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" -- -- (1,getLine)^!!_2.acts.folded.to succ -- aa -- "bb" acts :: IndexPreservingAction 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 a -> IndexPreservingAction (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 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 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 a -> (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 a -> 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 a -> 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 a -> 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 #-}