How to use thread safe shared variables in Haskell - haskell

IORefs, MVars, and TVars can be used to wrap a shared variable in a concurrent context. I've studied concurrent haskell for a while and now I've encounted some questions. After searching on stackoverflow and read through some related question, my questions are not fully resolved.
According to the IORef documentation,"Extending the atomicity to multiple IORefs is problematic", can someone help to explain why a single IORef is safe but more than one IORefs are problematic?
modifyMVar is "exception-safe, but only atomic if there are no other producers for this MVar". See MVar's documentation. The source code show that modifyMVar does only compose a getMVar and putMVar sequencially, indicating that it's note thread-safe if there is another producer. But if there is no producer and all threads behave in the "takeMVar then putMVar" way, then is it thread-safe to simply use modifyMVar ?
To give a concrete situation, I'll show the actual problem. I've some shared variables which are never empty and I want them be mutable states so some threads can simultaneously modify these variables.
OK, it seems tha TVar solve everything clearly. But I'm not satisfied with it and I'm eager for answers to the questions above. Any help are appreciated.
-------------- re: #GabrielGonzalez BFS interface code ------------------
Code below is my BFS interface using state monad.
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
module Data.Graph.Par.Class where
import Data.Ix
import Data.Monoid
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Trans.State
class (Ix (Vertex g), Ord (Edge g), Ord (Path g)) => ParGraph g where
type Vertex g :: *
type Edge g :: *
-- type Path g :: * -- useless
type VertexProperty g :: *
type EdgeProperty g :: *
edges :: g a -> IO [Edge g]
vertexes :: g a -> IO [Vertex g]
adjacencies :: g a -> Vertex g -> IO [Vertex g]
vertexProperty :: Vertex g -> g a -> IO (VertexProperty g)
edgeProperty :: Edge g -> g a -> IO (EdgeProperty g)
atomicModifyVertexProperty :: (VertexProperty g -> IO (VertexProperty g)) ->
Vertex g -> g a -> IO (g a) -- fixed
spanForest :: ParGraph g => [Vertex g] -> StateT (g a) IO ()
spanForest roots = parallelise (map spanTree roots) -- parallel version
spanForestSeq :: ParGraph g => [Vertex g] -> StateT (g a) IO ()
spanForestSeq roots = forM_ roots spanTree -- sequencial version
spanTree :: ParGraph g => Vertex g -> StateT (g a) IO ()
spanTree root = spanTreeOneStep root >>= \res -> case res of
[] -> return ()
adjs -> spanForestSeq adjs
spanTreeOneStep :: ParGraph g => Vertex g -> StateT (g a) IO [Vertex g]
spanTreeOneStep v = StateT $ \g -> adjacencies g v >>= \adjs -> return (adjs, g)
parallelise :: (ParGraph g, Monoid b) => [StateT (g a) IO b] -> StateT (g a) IO b
parallelise [] = return mempty
parallelise ss = syncGraphOp $ map forkGraphOp ss
forkGraphOp :: (ParGraph g, Monoid b) => StateT (g a) IO b -> StateT (g a) IO (MVar b)
forkGraphOp t = do
s <- get
mv <- mapStateT (forkHelper s) t
return mv
where
forkHelper s x = do
mv <- newEmptyMVar
forkIO $ x >>= \(b, s) -> putMVar mv b
return (mv, s)
syncGraphOp :: (ParGraph g, Monoid b) => [StateT (g a) IO (MVar b)] -> StateT (g a) IO b
syncGraphOp [] = return mempty
syncGraphOp ss = collectMVars ss >>= waitResults
where
collectMVars [] = return []
collectMVars (x:xs) = do
mvx <- x
mvxs <- collectMVars xs
return (mvx:mvxs)
waitResults mvs = StateT $ \g -> forM mvs takeMVar >>= \res -> return ((mconcat res), g)

Modern processors offer a compare-and-swap instruction that atomically modifies a single pointer. I expect if you track down deep enough, you will find that this instruction is the one used to implement atomicModifyIORef. It is therefore easy to provide atomic access to a single pointer. However, because there isn't such hardware support for more than one pointer, whatever you need will have to be done in software. This typically involves inventing and manually enforcing a protocol in all your threads -- which is complicated and error-prone.
Yes, if all threads agree to only use the "single takeMVar followed by a single putMVar" behavior, then modifyMVar is safe.

Related

Is there a "chain" monad function in Haskell?

Explain about a "duplicate"
Someone point to Is this a case for foldM? as a possible duplicate. Now, I have a strong opinion that, two questions that can be answered with identical answers are not necessarily duplicates! "What is 1 - 2" and "What is i^2" both yields "-1", but no, they are not duplicate questions. My question (which is already answered, kind of) was about "whether the function iterateM exists in Haskell standard library", not "How to implement a chained monad action".
The question
When I write some projects, I found myself writing this combinator:
repeatM :: Monad m => Int -> (a -> m a) -> a -> m a
repeatM 0 _ a = return a
repeatM n f a = (repeatM (n-1) f) =<< f a
It just performs a monadic action n times, feeding the previous result into the next action. I tried some hoogle search and some Google search, and did not find anything that comes with the "standard" Haskell. Is there such a formal function that is predefined?
You can use foldM, e.g.:
import Control.Monad
f a = do print a; return (a+2)
repeatM n f a0 = foldM (\a _ -> f a) a0 [1..n]
test = repeatM 5 f 3
-- output: 3 5 7 9 11
Carsten mentioned replicate, and that's not a bad thought.
import Control.Monad
repeatM n f = foldr (>=>) pure (replicate n f)
The idea behind this is that for any monad m, the functions of type a -> m b form the Kleisli category of m, with identity arrows
pure :: a -> m a
(also called return)
and composition operator
(<=<) :: (b -> m c) -> (a -> m b) -> a -> m c
f <=< g = \a -> f =<< g a
Since were actually dealing with a function of type a -> m a, we're really looking at one monoid of the Kleisli category, so we can think about folding lists of these arrows.
What the code above does is fold the composition operator, flipped, into a list of n copies of f, finishing off with an identity as usual. Flipping the composition operator actually puts us into the dual category; for many common monads, x >=> y >=> z >=> w is more efficient than w <=< z <=< y <=< x; since all the arrows are the same in this case, it seems we might as well. Note that for the lazy state monad and likely also the reader monad, it may be better to use the unflipped <=< operator; >=> will generally be better for IO, ST s, and the usual strict state.
Notice: I am no category theorist, so there may be errors in the explanation above.
I find myself wanting this function often, I wish it had a standard name. That name however would not be repeatM - that would be for an infinite repeat, like forever if it existed, just for consistency with other libraries (and repeatM is defined in some libraries that way).
Just as another perspective from the answers already given, I point out that (s -> m s) looks a bit like an action in a State monad with state type s.
In fact, it is isomorphic to StateT s m () - an action which returns no value, because all the work it does is encapsulated in the way it changes the state. In this monad, the function you wanted really is replicateM. You can write it this way in haskell although it probably looks uglier than just writing it directly.
First convert s -> m s to the equivalent form which StateT uses, adding the information-free (), using liftM to map a function over the return type.
> :t \f -> liftM (\x -> ((),x)) . f
\f -> liftM (\x -> ((),x)) . f :: Monad m => (a -> m t) -> a -> m ((), t)
(could have used fmap but the Monad constraint seems clearer here; could have used TupleSections if you like; if you find do notation easier to read it is simply \f s -> do x <- f s; return ((),s) ).
Now this has the right type to wrap up with StateT:
> :t StateT . \f -> liftM (\x -> ((),x)) . f
StateT . \f -> liftM (\x -> ((),x)) . f :: Monad m => (s -> m s) -> StateT s m ()
and then you can replicate it n times, using the replicateM_ version because the returned list [()] from replicateM would not be interesting:
> :t \n -> replicateM_ n . StateT . \f -> liftM (\x -> ((),x)) . f
\n -> replicateM_ n . StateT . \f -> liftM (\x -> ((),x)) . f :: Monad m => Int -> (s -> m s) -> StateT s m ()
and finally you can use execStateT to go back to the Monad you were originally working in:
runNTimes :: Monad m => Int -> (s -> m s) -> s -> m s
runNTimes n act =
execStateT . replicateM_ n . StateT . (\f -> liftM (\x -> ((),x)) . f) $ act

Working with the `MonadBaseControl` API

I am currently playing with the Bryan O'Sullivan's resource-pool library and have a question regarding extending the withResource function.
I want to change the signature of the withResource function from (MonadBaseControl IO m) => Pool a -> (a -> m b) -> m b to (MonadBaseControl IO m) => Pool a -> (a -> m (Bool, b)) -> m b.
What I want to achieve is, that the action should return (Bool, b) tuple, where the boolean value indicates if the borrowed resource should
be put back into the pool or destroyed.
Now my current implementation looks like this:
withResource :: forall m a b. (MonadBaseControl IO m) => Pool a -> (a -> m (Bool, b)) -> m b
{-# SPECIALIZE withResource :: Pool a -> (a -> IO (Bool,b)) -> IO b #-}
withResource pool act = fmap snd result
where
result :: m (Bool, b)
result = control $ \runInIO -> mask $ \restore -> do
resource <- takeResource pool
ret <- restore (runInIO (act resource)) `onException`
destroyResource pool resource
void . runInIO $ do
(keep, _) <- restoreM ret :: m (Bool, b)
if keep
then liftBaseWith . const $ putResource pool resource
else liftBaseWith . const $ destroyResource pool resource
return ret
And I have a feeling, that this is not how it is supposed to look like...
Maybe I am not using the MonadBaseControl API right.
What do you guys think of this and how can I improve it to be more idiomatic?
I have a feeling that there is a fundamental problem with this approach. For monads for which StM M a is equal/isomorphic to a it will work. But for other monads there will be a problem. Let's consider MaybeT IO. An action of type a -> MaybeT IO (Bool, b) can fail, so there will be no Bool value produced. And the code in
void . runInIO $ do
(keep, _) <- restoreM ret :: m (Bool, b)
...
won't be executed, the control flow will stop at restoreM. And for ListT IO it'll be even worse, as putResource and destroyResource will be executed multiple times. Consider this sample program, which is a simplified version of your function:
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, RankNTypes, TupleSections #-}
import Control.Monad
import Control.Monad.Trans.Control
import Control.Monad.Trans.List
foo :: forall m b . (MonadBaseControl IO m) => m (Bool, b) -> m b
foo act = fmap snd result
where
result :: m (Bool, b)
result = control $ \runInIO -> do
ret <- runInIO act
void . runInIO $ do
(keep, _) <- restoreM ret :: m (Bool, b)
if keep
then liftBaseWith . const $ putStrLn "return"
else liftBaseWith . const $ putStrLn "destroy"
return ret
main :: IO ()
main = void . runListT $ foo f
where
f = msum $ map (return . (, ())) [ False, True, False, True ]
It'll print
destroy
return
destroy
return
And for an empty list, nothing gets printed, which means no cleanup would be called in your function.
I have to say I'm not sure how to achieve your goal in a better way. I'd try to explore in the direction of signature
withResource :: forall m a b. (MonadBaseControl IO m)
=> Pool a -> (a -> IO () -> m b) -> m b
where the IO () argument would be a function, that when executed, invalidates the current resource and marks it to be destroyed. (Or, for better convenience, replace IO () with lifted m ()). Then internally, as it's IO-based, I'd just create a helper MVar that'd be reset by calling
the function, and at the end, based on the value, either return or destroy the resource.

Single-stepping a conduit

I want to do something along the lines of ArrowChoice, but with conduits. I want to await an Either value and then pass Left values to one conduit and Right values to another, and then merge the results back into an Either stream.
Presumably this can be done by making the inner conduits like automata: turn a conduit into a function that takes an argument and returns a monadic list of outputs yielded:
newtype AutomataM i m o = Automata (i -> m (o, Automata i o))
conduitStep :: Conduit i m o -> AutomataM i m [o]
The reason for the list of outputs is that a Conduit may yield 0 or more outputs for each input.
I've looked at ResumableConduit and its relatives, and presumably the answer is in there somewhere. But I can't quite see how its done.
It's not exactly the same type signature you provided, but:
import Data.Conduit
import Data.Conduit.Internal (Pipe (..), ConduitM (..))
newtype Automata i o m r = Automata (m ([o], Either r (i -> Automata i o m r)))
conduitStep :: Monad m => ConduitM i o m r -> Automata i o m r
conduitStep (ConduitM con0) =
Automata $ go [] id con0
where
go _ front (Done r) = return (front [], Left r)
go ls front (HaveOutput p _ o) = go ls (front . (o:)) p
go ls front (NeedInput p _) =
case ls of
[] -> return (front [], Right $ conduitStep . ConduitM . p)
l:ls' -> go ls' front (p l)
go ls front (PipeM mp) = mp >>= go ls front
go ls front (Leftover p l) = go (l:ls) front p
But just be careful with this approach:
By keeping the output as a list, it's not constant memory.
We're throwing away finalizers.
There's probably a way to provide a ZipConduit abstraction, similar to ZipSource and ZipSink, that would handle this kind of problem more elegantly, but I haven't thought about it too much.
EDIT I ended up implementing ZipConduit in conduit-extra 0.1.5. Here's a demonstration of using it which sounds a bit like your case:
import Control.Applicative
import Data.Conduit
import Data.Conduit.Extra
import qualified Data.Conduit.List as CL
conduit1 :: Monad m => Conduit Int m String
conduit1 = CL.map $ \i -> "conduit1: " ++ show i
conduit2 :: Monad m => Conduit Double m String
conduit2 = CL.map $ \d -> "conduit2: " ++ show d
conduit :: Monad m => Conduit (Either Int Double) m String
conduit = getZipConduit $
ZipConduit (lefts =$= conduit1) *>
ZipConduit (rights =$= conduit2)
where
lefts = CL.mapMaybe (either Just (const Nothing))
rights = CL.mapMaybe (either (const Nothing) Just)
main :: IO ()
main = do
let src = do
yield $ Left 1
yield $ Right 2
yield $ Left 3
yield $ Right 4
sink = CL.mapM_ putStrLn
src $$ conduit =$ sink
There's a folk method of doing this using pipes by using "push-category" Pipes. The complete implementation comes from both this mailing list post and this Stack Overflow answer. I think it hasn't been released yet due to both an effort to simplify the Pipes interface, a focus on using the "sequencing" monad instance which is hidden via this method, and no proof yet that this implementation truly implements the Arrow class properly.
The idea is to implement a newtype Edge (demonstrated below) which is a push-based pipe with the type arguments in the right order for Category, Arrow, ArrowChoice and both Functor and Applicative over their output values. This lets you compose them into directed acyclic graphs using arrow notation. I'll run over the implementation below, but it's safe to just ignore it and use the Arrow/ArrowChoice/Applicative instances of Edge without too much concern.
(Edit: This code is best made available at https://github.com/Gabriel439/Haskell-RCPL-Library)
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
import Prelude hiding ((.), id)
import Pipes.Core
import Pipes.Lift
import Control.Monad.Morph
import Control.Category
import Control.Monad.State.Strict
import Control.Arrow
This is an atypical mode of using pipes and isn't exposed in the Pipes module; you must import Pipes.Core to use push. Push-based pipes look like
-- push :: a -> Proxy a' a a' a m r
and thus they demand at least one upstream value before the Proxy is allowed to run. This means the whole process needs to be "kickstarted" by passing the first value as a function call and that the leftmost push-Proxy will control the entire stream.
Given a push-based pipe we can implement Category, Arrow and ArrowChoice. The standard solution also involves the Edge typeclass so that we have the type arguments in the right order for Category and Arrow
newtype Edge m r a b = Edge { unEdge :: a -> Pipe a b m r }
For the Category instance, we use the "push" Category which has push as id and (<~<) as composition:
instance Monad m => Category (Edge m r) where
id = Edge push
Edge a . Edge b = Edge (a <~< b)
We embed functions into Edge with arr by augmenting id (i.e. push) on the downward edge. To do this we use the respond category which has the law p />/ respond == p, but jam our f into the process.
instance Monad m => Arrow (Edge m r) where
arr f = Edge (push />/ respond . f)
We also use a local state transformer to store the snd half of our pairs and pass it "around" the input pipe in first
first (Edge p) = Edge $ \(b, d) ->
evalStateP d $ (up \>\ hoist lift . p />/ dn) b
where
up () = do
(b, d) <- request ()
lift (put d)
return b
dn c = do
d <- lift get
respond (c, d)
Finally, we get an ArrowChoice instance by implementing left. To do so we split the burden of passing the Left and Right sides using either the return or the pipe to pass values.
instance (Monad m) => ArrowChoice (Edge m r) where
left (Edge k) = Edge (bef >=> (up \>\ (k />/ dn)))
where
bef x = case x of
Left b -> return b
Right d -> do
_ <- respond (Right d)
x2 <- request ()
bef x2
up () = do
x <- request ()
bef x
dn c = respond (Left c)
We can use Edge to create "push-based" producers and consumers
type PProducer m r b = Edge m r () b
type PConsumer m r a = forall b . Edge m r a b
and then we'll provide Functor and Applicative instances for PProducer. This goes by case analysis on the underlying Pipe, so it's a bit verbose. Essentially, however, all that happens is that we insert f into the yield slot of the Pipe.
instance Functor (PProducer m r) where
fmap f (Edge k) = $ Edge $ \() -> go (k ()) where
go p = case p of
Request () ku -> Request () (\() -> go (ku ()))
-- This is the only interesting line
Respond b ku -> Respond (f b) (\() -> go (ku ()))
M m -> M (m >>= \p' -> return (go p'))
Pure r -> Pure r
Finally, Applicative is much the same except that we have to switch between running the upstream pipe to produce functions and running the downstream pipe to produce arguments.
instance (Monad m) => Applicative (Edge m r ()) where
pure b = Edge $ \() -> forever $ respond b
(Edge k1) <*> (Edge k2) = Edge (\() -> goL (k1 ()) (k2 ()))
where
goL p1 p2 = case p1 of
Request () ku -> Request () (\() -> goL (ku ()) p2)
Respond f ku -> goR f (ku ()) p2
M m -> M (m >>= \p1' -> return (goL p1' p2))
Pure r -> Pure r
goR f p1 p2 = case p2 of
Request () ku -> Request () (\() -> goR f p1 (ku ()))
Respond x ku -> Respond (f x) (\() -> goL p1 (ku ()))
M m -> M (m >>= \p2' -> return (goR f p1 p2'))
Pure r -> Pure r

Can I make a Lens with a Monad constraint?

Context: This question is specifically in reference to Control.Lens (version 3.9.1 at the time of this writing)
I've been using the lens library and it is very nice to be able to read and write to a piece (or pieces for traversals) of a structure. I then had a though about whether a lens could be used against an external database. Of course, I would then need to execute in the IO Monad. So to generalize:
Question:
Given a getter, (s -> m a) and an setter (b -> s -> m t) where m is a Monad, is possible to construct Lens s t a b where the Functor of the lens is now contained to also be a Monad? Would it still be possible to compose these with (.) with other "purely functional" lenses?
Example:
Could I make Lens (MVar a) (MVar b) a b using readMVar and withMVar?
Alternative:
Is there an equivalent to Control.Lens for containers in the IO monad such as MVar or IORef (or STDIN)?
I've been thinking about this idea for some time, which I'd call mutable lenses. So far, I haven't made it into a package, let me know, if you'd benefit from it.
First let's recall the generalized van Laarhoven Lenses (after some imports we'll need later):
{-# LANGUAGE RankNTypes #-}
import qualified Data.ByteString as BS
import Data.Functor.Constant
import Data.Functor.Identity
import Data.Traversable (Traversable)
import qualified Data.Traversable as T
import Control.Monad
import Control.Monad.STM
import Control.Concurrent.STM.TVar
type Lens s t a b = forall f . (Functor f) => (a -> f b) -> (s -> f t)
type Lens' s a = Lens s s a a
we can create such a lens from a "getter" and a "setter" as
mkLens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
mkLens g s f x = fmap (s x) (f (g x))
and get a "getter"/"setter" from a lens back as
get :: Lens s t a b -> (s -> a)
get l = getConstant . l Constant
set :: Lens s t a b -> (s -> b -> t)
set l x v = runIdentity $ l (const $ Identity v) x
as an example, the following lens accesses the first element of a pair:
_1 :: Lens' (a, b) a
_1 = mkLens fst (\(x, y) x' -> (x', y))
-- or directly: _1 f (a,c) = (\b -> (b,c)) `fmap` f a
Now how a mutable lens should work? Getting some container's content involves a monadic action. And setting a value doesn't change the container, it remains the same, just as a mutable piece of memory does. So the result of a mutable lens will have to be monadic, and instead of the return type container t we'll have just (). Moreover, the Functor constraint isn't enough, since we need to interleave it with monadic computations. Therefore, we'll need Traversable:
type MutableLensM m s a b
= forall f . (Traversable f) => (a -> f b) -> (s -> m (f ()))
type MutableLensM' m s a
= MutableLensM m s a a
(Traversable is to monadic computations what Functor is to pure computations).
Again, we create helper functions
mkLensM :: (Monad m) => (s -> m a) -> (s -> b -> m ())
-> MutableLensM m s a b
mkLensM g s f x = g x >>= T.mapM (s x) . f
mget :: (Monad m) => MutableLensM m s a b -> s -> m a
mget l s = liftM getConstant $ l Constant s
mset :: (Monad m) => MutableLensM m s a b -> s -> b -> m ()
mset l s v = liftM runIdentity $ l (const $ Identity v) s
As an example, let's create a mutable lens from a TVar within STM:
alterTVar :: MutableLensM' STM (TVar a) a
alterTVar = mkLensM readTVar writeTVar
These lenses are one-sidedly directly composable with Lens, for example
alterTVar . _1 :: MutableLensM' STM (TVar (a, b)) a
Notes:
Mutable lenses could be made more powerful if we allow that the modifying function to include effects:
type MutableLensM2 m s a b
= (Traversable f) => (a -> m (f b)) -> (s -> m (f ()))
type MutableLensM2' m s a
= MutableLensM2 m s a a
mkLensM2 :: (Monad m) => (s -> m a) -> (s -> b -> m ())
-> MutableLensM2 m s a b
mkLensM2 g s f x = g x >>= f >>= T.mapM (s x)
However, it has two major drawbacks:
It isn't composable with pure Lens.
Since the inner action is arbitrary, it allows you to shoot yourself in the foot by mutating this (or other) lens during the mutating operation itself.
There are other possibilities for monadic lenses. For example, we can create a monadic copy-on-write lens that preserves the original container (just as Lens does), but where the operation involves some monadic action:
type LensCOW m s t a b
= forall f . (Traversable f) => (a -> f b) -> (s -> m (f t))
I've made jLens - a Java library for mutable lenses, but the API is of course far from being as nice as Haskell lenses.
No, you can not constrain the "Functor of the lens" to also be a Monad. The type for a Lens requires that it be compatible with all Functors:
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
This reads in English something like: A Lens is a function, which, for all types f where f is a Functor, takes an (a -> f b) and returns an s -> f t. The key part of that is that it must provide such a function for every Functor f, not just some subset of them that happen to be Monads.
Edit:
You could make a Lens (MVar a) (MVar b) a b, since none of s t a, or b are constrained. What would the types on the getter and setter needed to construct it be then? The type of the getter would be (MVar a -> a), which I believe could only be implemented as \_ -> undefined, since there's nothing that extracts the value from an MVar except as IO a. The setter would be (MVar a -> b -> MVar b), which we also can't define since there's nothing that makes an MVar except as IO (MVar b).
This suggests that instead we could instead make the type Lens (MVar a) (IO (MVar b)) (IO a) b. This would be an interesting avenue to pursue further with some actual code and a compiler, which I don't have right now. To combine that with other "purely functional" lenses, we'd probably want some sort of lift to lift the lens into a monad, something like liftLM :: (Monad m) => Lens s t a b -> Lens s (m t) (m a) b.
Code that compiles (2nd edit):
In order to be able to use the Lens s t a b as a Getter s a we must have s ~ t and a ~ b. This limits our type of useful lenses lifted over some Monad to the widest type for s and t and the widest type for a and b. If we substitute b ~ a into out possible type we would have Lens (MVar a) (IO (MVar a)) (IO a) a, but we still need MVar a ~ IO (MVar a) and IO a ~ a. We take the wides of each of these types, and choose Lens (IO (MVar a)) (IO (MVar a)) (IO a) (IO a), which Control.Lens.Lens lets us write as Lens' (IO (MVar a)) (IO a). Following this line of reasoning, we can make a complete system for combining "purely functional" lenses with lenses on monadic values. The operation to lift a "purely function" lens, liftLensM, then has the type (Monad m) => Lens' s a -> LensF' m s a, where LensF' f s a ~ Lens' (f s) (f a).
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
module Main (
main
) where
import Control.Lens
import Control.Concurrent.MVar
main = do
-- Using MVar
putStrLn "Ordinary MVar"
var <- newMVar 1
output var
swapMVar var 2
output var
-- Using mvarLens
putStrLn ""
putStrLn "MVar accessed through a LensF' IO"
value <- (return var) ^. mvarLens
putStrLn $ show value
set mvarLens (return 3) (return var)
output var
-- Debugging lens
putStrLn ""
putStrLn "MVar accessed through a LensF' IO that also debugs"
value <- readM (debug mvarLens) var
putStrLn $ show value
setM (debug mvarLens) 4 var
output var
-- Debugging crazy box lens
putStrLn ""
putStrLn "MVar accessed through a LensF' IO that also debugs through a Box that's been lifted to LensF' IO that also debugs"
value <- readM ((debug mvarLens) . (debug (liftLensM boxLens))) var
putStrLn $ show value
setM ((debug mvarLens) . (debug (liftLensM boxLens))) (Box 5) var
output var
where
output = \v -> (readMVar v) >>= (putStrLn . show)
-- Types to write higher lenses easily
type LensF f s t a b = Lens (f s) (f t) (f a) (f b)
type LensF' f s a = Lens' (f s) (f a)
type GetterF f s a = Getter (f s) (f a)
type SetterF f s t a b = Setter (f s) (f t) (f a) (f b)
-- Lenses for MVars
setMVar :: IO (MVar a) -> IO a -> IO (MVar a)
setMVar ioVar ioValue = do
var <- ioVar
value <- ioValue
swapMVar var value
return var
getMVar :: IO (MVar a) -> IO a
getMVar ioVar = do
var <- ioVar
readMVar var
-- (flip (>>=)) readMVar
mvarLens :: LensF' IO (MVar a) a
mvarLens = lens getMVar setMVar
-- Lift a Lens' to a Lens' on monadic values
liftLensM :: (Monad m) => Lens' s a -> LensF' m s a
liftLensM pureLens = lens getM setM
where
getM mS = do
s <- mS
return (s^.pureLens)
setM mS mValue = do
s <- mS
value <- mValue
return (set pureLens value s)
-- Output when a Lens' is used in IO
debug :: (Show a) => LensF' IO s a -> LensF' IO s a
debug l = lens debugGet debugSet
where
debugGet ioS = do
value <- ioS^.l
putStrLn $ show $ "Getting " ++ (show value)
return value
debugSet ioS ioValue = do
value <- ioValue
putStrLn $ show $ "Setting " ++ (show value)
set l (return value) ioS
-- Easier way to use lenses in a monad (if you don't like writing return for each argument)
readM :: (Monad m) => GetterF m s a -> s -> m a
readM l s = (return s) ^. l
setM :: (Monad m) => SetterF m s t a b -> b -> s -> m t
setM l b s = set l (return b) (return s)
-- Another example lens
newtype Boxed a = Box {
unBox :: a
} deriving Show
boxLens :: Lens' a (Boxed a)
boxLens = lens Box (\_ -> unBox)
This code produces the following output:
Ordinary MVar
1
2
MVar accessed through a LensF' IO
2
3
MVar accessed through a LensF' IO that also debugs
"Getting 3"
3
"Setting 4"
4
MVar accessed through a LensF' IO that also debugs through a Box that's been lifted to LensF' IO that also debugs
"Getting 4"
"Getting Box {unBox = 4}"
Box {unBox = 4}
"Setting Box {unBox = 5}"
"Getting 4"
"Setting 5"
5
There's probably a better way to write liftLensM without resorting to using lens, (^.), set and do notation. Something seems wrong about building lenses by extracting the getter and setter and calling lens on a new getter and setter.
I wasn't able to figure out how to reuse a lens as both a getter and a setter. readM (debug mvarLens) and setM (debug mvarLens) both work just fine, but any construct like 'let debugMVarLens = debug mvarLens' loses either the fact it works as a Getter, the fact it works as a Setter, or the knowledge that Int is an instance of show so it can me used for debug. I'd love to see a better way of writing this part.
I had the same problem. I tried the methods in Petr and Cirdec's answers but never got to the point I wanted to. Started working on the problem, and at the end, I published the references library on hackage with a generalization of lenses.
I followed the idea of the yall library to parameterize the references with monad types. As a result there is an mvar reference in Control.Reference.Predefined. It is an IO reference, so an access to the referenced value is done in an IO action.
There are also other applications of this library, it is not restricted to IO. An additional feature is to add references (so adding _1 and _2 tuple accessors will give a both traversal, that accesses both fields). It can also be used to release resources after accessing them, so it can be used to manipulate files safely.
The usage is like this:
test =
do result <- newEmptyMVar
terminator <- newEmptyMVar
forkIO $ (result ^? mvar) >>= print >> (mvar .= ()) terminator >> return ()
hello <- newMVar (Just "World")
forkIO $ ((mvar & just & _tail & _tail) %~= ('_':) $ hello) >> return ()
forkIO $ ((mvar & just & element 1) .= 'u' $ hello) >> return ()
forkIO $ ((mvar & just) %~= ("Hello" ++) $ hello) >> return ()
x <- runMaybeT $ hello ^? (mvar & just)
mvar .= x $ result
terminator ^? mvar
The operator & combines lenses, ^? is generalized to handle references of any monad, not just a referenced value that may not exist. The %~= operator is an update of a monadic reference with a pure function.

Strict fmap using only Functor, not Monad

One irritation with lazy IO caught to my attention recently
import System.IO
import Control.Applicative
main = withFile "test.txt" ReadMode getLines >>= mapM_ putStrLn
where getLines h = lines <$> hGetContents h
Due to lazy IO, the above program prints nothing. So I imagined this could be solved with a strict version of fmap. And indeed, I did come up with just such a combinator:
forceM :: Monad m => m a -> m a
forceM m = do v <- m; return $! v
(<$!>) :: Monad m => (a -> b) -> m a -> m b
f <$!> m = liftM f (forceM m)
Replacing <$> with <$!> does indeed alleviate the problem. However, I am not satisfied. <$!> has a Monad constraint, which feels too tight; it's companion <$> requires only Functor.
Is there a way to write <$!> without the Monad constraint? If so, how? If not, why not? I've tried throwing strictness all over the place, to no avail (following code does not work as desired):
forceF :: Functor f => f a -> f a
forceF m = fmap (\x -> seq x x) $! m
(<$!>) :: Functor f => (a -> b) -> f a -> f b
f <$!> m = fmap (f $!) $! (forceF $! m)
I don't think it's possible, and also the monadic forceM doesn't work for all monads:
module Force where
import Control.Monad.State.Lazy
forceM :: Monad m => m a -> m a
forceM m = do v <- m; return $! v
(<$!>) :: Monad m => (a -> b) -> m a -> m b
f <$!> m = liftM f (forceM m)
test :: Int
test = evalState (const 1 <$!> undefined) True
And the evaluation:
Prelude Force> test
1
forceM needs a strict enough (>>=) to actually force the result of its argument. Functor doesn't even have a (>>=). I don't see how one could write an effective forceF. (That doesn't prove it's impossible, of course.)

Resources