I am working with the Haskell pipes package.
I am trying to use pipes-concurrency to merge a list of Producers together.
What I want to arrive at is:
merge :: MonadIO m => [Producer a m ()] -> Producer a m ()
so given a producer s1 and another producer s2: r = merge [s1, s2]
which would give the behaviour:
s1 --1--1--1--|
s2 ---2---2---2|
r --12-1-21--2|
Following the code in the tutorial page I came up with:
mergeIO :: [Producer a IO ()] -> Producer a IO ()
mergeIO producers = do
(output, input) <- liftIO $ spawn Unbounded
_ <- liftIO $ mapM (fork output) producers
fromInput input
where
fork :: Output a -> Producer a IO () -> IO ()
fork output producer = void $ forkIO $ do runEffect $ producer >-> toOutput output
performGC
which works as expected.
However I am having difficulty generalizing things.
My attempt:
merge :: (MonadIO m) => [Producer a m ()] -> Producer a m ()
merge producers = do
(output, input) <- liftIO $ spawn Unbounded
_ <- liftIO $ mapM (fork output) producers
fromInput input
where
runEffectIO :: Monad m => Effect m r -> IO (m r)
runEffectIO e = do
x <- evaluate $ runEffect e
return x
fork output producer = forkIO $ do runEffectIO $ producer >-> toOutput output
performGC
Unfortunately this compiles but does not do all too much else. I am guessing that I am making a mess of runEffectIO. Other approaches to my current runEffectIO have yielded no better results.
The program:
main = do
let producer = merge [repeater 1 (100 * 1000), repeater 2 (150 * 1000)]
_ <- runEffect $ producer >-> taker 20
where repeater :: Int -> Int -> Producer Int IO r
repeater val delay = forever $ do
lift $ threadDelay delay
yield val
taker :: Int -> Consumer Int IO ()
taker 0 = return ()
taker n = do
val <- await
liftIO $ putStrLn $ "Taker " ++ show n ++ ": " ++ show val
taker $ n - 1
hits val <- await but does not get to liftIO $ putStrLn thus it produces no output. However it exits fine without hanging.
When I substitute in mergeIO for merge then the program runs I would expect outputting 20 lines.
While MonadIO is not sufficient for this operation, MonadBaseControl (from monad-control) is designed to allow embedding arbitrary transformer stacks inside the base monad. The companion package lifted-base provides a version of fork which will work for transformer stacks. I've put together an example of using it to solve your problem in the following Gist, though the main magic is:
import qualified Control.Concurrent.Lifted as L
fork :: (MonadBaseControl IO m, MonadIO m) => Output a -> Producer a m () -> m ThreadId
fork output producer = L.fork $ do
runEffect $ producer >-> toOutput output
liftIO performGC
Note that you should understand what happens to monadic states when treated this way: modifications to any mutable state performed in the child threads will be isolated to just those child threads. In other words, if you were using a StateT, each child thread would start off with the same state value that was in context when it was forked, but then you would have many different states that do not update each other.
There's an appendix in the Yesod book on monad-control, though frankly it's a bit dated. I'm just not aware of any more recent tutorials.
The problem seems to be your use of evaluate, which I assume it is the evaluate from Control.Exception.
You seem to be using it to "convert" a value inside the generic monad m into IO, but it doesn't really work that way. You are just obtaining the m value out of the Effect and then returning it inside IO without actually executing it. The following code doesn't print "foo":
evaluate (putStrLn "foo") >> return ""
Maybe your merge function could take as an additional parameter a function m a -> IO a so that merge knows how to bring the result of runEffect into IO.
Unfortunately, you can't fork a Producer with a MonadIO base monad (or any MonadIO computation for that matter). You need to specifically include the logic necessary to run all other monad transformers to get back an IO action before you can fork the computation.
Related
I am using a library that I can provide with a function a -> IO (), which it will call occasionally.
Because the output of my function depends not only on the a it receives as input, but also on the previous a's, it would be much easier for me to write a function [a] -> IO (), where [a] is infinite.
Can I write a function:
magical :: ([a] -> IO ()) -> (a -> IO ())
That collects the a's it receives from the callback and passes them to my function as a lazy infinite list?
The IORef solution is indeed the simplest one. If you'd like to explore a pure (but more complex) variant, have a look at conduit. There are other implementations of the same concept, see Iteratee I/O, but I found myself conduit to be very easy to use.
A conduit (AKA pipe) is an abstraction of of program that can accept input and/or produce output. As such, it can keep internal state, if needed. In your case, magical would be a sink, that is, a conduit that accepts input of some type, but produces no output. By wiring it into a source, a program that produces output, you complete the pipeline and then ever time the sink asks for an input, the source is run until it produces its output.
In your case you'd have roughly something like
magical :: Sink a IO () -- consumes a stream of `a`s, no result
magical = go (some initial state)
where
go state = do
m'input <- await
case m'input of
Nothing -> return () -- finish
Just input -> do
-- do something with the input
go (some updated state)
This is not exactly what you asked for, but it might be enough for your purposes, I think.
magical :: ([a] -> IO ()) -> IO (a -> IO ())
magical f = do
list <- newIORef []
let g x = do
modifyIORef list (x:)
xs <- readIORef list
f xs -- or (reverse xs), if you need FIFO ordering
return g
So if you have a function fooHistory :: [a] -> IO (), you can use
main = do
...
foo <- magical fooHistory
setHandler foo -- here we have foo :: a -> IO ()
...
As #danidaz wrote above, you probably do not need magical, but can play the same trick directly in your fooHistory, modifying a list reference (IORef [a]).
main = do
...
list <- newIORef []
let fooHistory x = do
modifyIORef list (x:)
xs <- readIORef list
use xs -- or (reverse xs), if you need FIFO ordering
setHandler fooHistory -- here we have fooHistory :: a -> IO ()
...
Control.Concurrent.Chan does almost exactly what I wanted!
import Control.Monad (forever)
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan
setHandler :: (Char -> IO ()) -> IO ()
setHandler f = void . forkIO . forever $ getChar >>= f
process :: String -> IO ()
process ('h':'i':xs) = putStrLn "hi" >> process xs
process ('a':xs) = putStrLn "a" >> process xs
process (x:xs) = process xs
process _ = error "Guaranteed to be infinite"
main :: IO ()
main = do
c <- newChan
setHandler $ writeChan c
list <- getChanContents c
process list
This seems like a flaw in the library design to me. You might consider an upstream patch so that you could provide something more versatile as input.
By default pipes are pull based. This is due to the operator >-> which is implemented via +>> which is the pointful bind operator for his pull category. My understanding is that this means that if you have code like producer >-> consumer, the consumer's body will be called first, then once it awaits data, the producer will be called.
I've seen in the pipes documentation here that you can use the code (reflect .) from Pipes.Core to turn a pull based pipe into a push based pipe. That means instead (correct me if I'm wrong) that in the code above producer >-> consumer, the producer is run first, produces a value, then the consumer tries to consume. That seems really useful and I'd like to know how to do it.
I've also seen in discussions here that there is no push based counterpart to >-> because it is easy to turn any pipe around (I assume with reflect?), but I can't really figure how to do it or find any examples.
Here's some code I've attempted:
stdin :: Producer String IO r
stdin = forever $ do
lift $ putStrLn "stdin"
str <- lift getLine
yield str
countLetters :: Consumer String IO r
countLetters = forever $ do
lift $ putStrLn "countLetters"
str <- await
lift . putStrLn . show . length $ str
-- this works in pull mode
runEffect (stdin >-> countLetters)
-- equivalent to above, works
runEffect ((\() -> stdin) +>> countLetters)
-- push based operator, doesn't do what I hoped
runEffect (stdin >>~ (\_ -> countLetters))
-- does not compile
runEffect (countLetters >>~ (\() -> stdin))
-- push based operator, doesn't do what I hoped
runEffect (stdin >>~ (\_ -> countLetters))
I gather the problem here is that, while the producer is ran first as expected, the first produced value is dropped. Compare...
GHCi> runEffect (stdin >-> countLetters)
countLetters
stdin
foo
3
countLetters
stdin
glub
4
countLetters
stdin
... with:
GHCi> runEffect (stdin >>~ (\_ -> countLetters))
stdin
foo
countLetters
stdin
glub
4
countLetters
stdin
This issue is discussed in detail by Gabriella Gonzalez's answer to this question. It boils down to how the argument to the function you give to (>>~) is the "driving" input in the push-based flow, and so if you const it away you end up dropping the first input. The solution is to reshape countLetters accordingly:
countLettersPush :: String -> Consumer String IO r
countLettersPush str = do
lift $ putStrLn "countLetters"
lift . putStrLn . show . length $ str
str' <- await
countLettersPush str'
GHCi> runEffect (stdin >>~ countLettersPush)
stdin
foo
countLetters
3
stdin
glub
countLetters
4
stdin
I've also seen in discussions here that there is no push based counterpart to >-> because it is easy to turn any pipe around (I assume with reflect?)
I'm not fully sure of my ground, but it seems that doesn't quite apply to the solution above. What we can do, now that we have the push-based flow working correctly, is using reflect to turn it around back to a pull-based flow:
-- Preliminary step: switching to '(>~>)'.
stdin >>~ countLettersPush
(const stdin >~> countLettersPush) ()
-- Applying 'reflect', as the documentation suggests.
reflect . (const stdin >~> countLettersPush)
reflect . const stdin <+< reflect . countLettersPush
const (reflect stdin) <+< reflect . countLettersPush
-- Rewriting in terms of '(+>>)'.
(reflect . countLettersPush >+> const (reflect stdin)) ()
reflect . countLettersPush +>> reflect stdin
This is indeed pull-based, as the flow is driven by reflect stdin, the downstream Client:
GHCi> :t reflect stdin
reflect stdin :: Proxy String () () X IO r
GHCi> :t reflect stdin :: Client String () IO r
reflect stdin :: Client String () IO r :: Client String () IO r
The flow, however, involves sending Strings upstream, and so it cannot be expressed in terms of (>->), which is, so to say, downstream-only:
GHCi> -- Compare the type of the second argument with that of 'reflect stdin'
GHCi> :t (>->)
(>->)
:: Monad m =>
Proxy a' a () b m r -> Proxy () b c' c m r -> Proxy a' a c' c m
I'm trying to work out if it's possible to write an abstraction for the following situation. Suppose I have a type a with function a -> m Bool e.g. MVar Bool and readMVar. To abstract this concept out I create a newtype wrapper for the type and its function:
newtype MPredicate m a = MPredicate (a,a -> m Bool)
I can define a fairly simple operation like so:
doUnless :: (Monad m) => Predicate m a -> m () -> m ()
doUnless (MPredicate (a,mg)) g = mg a >>= \b -> unless b g
main = do
b <- newMVar False
let mpred = MPredicate (b,readMVar)
doUnless mpred (print "foo")
In this case doUnless would print "foo". Aside: I'm not sure whether a type class might be more appropriate to use instead of a newtype.
Now take the code below, which outputs an incrementing number then waits a second and repeats. It does this until it receives a "turn off" instruction via the MVar.
foobar :: MVar Bool -> IO ()
foobar mvb = foobar' 0
where
foobar' :: Int -> IO ()
foobar' x = readMVar mvb >>= \b -> unless b $ do
let x' = x + 1
print x'
threadDelay 1000000
foobar' x'
goTillEnter :: MVar Bool -> IO ()
goTillEnter mv = do
_ <- getLine
_ <- takeMVar mv
putMVar mv True
main = do
mvb <- newMVar False
forkIO $ foobar mvb
goTillEnter mvb
Is it possible to refactor foobar so that it uses MPredicate and doUnless?
Ignoring the actual implementation of foobar' I can think of a simplistic way of doing something similar:
cycleUnless :: x -> (x -> x) -> MPredicate m a -> m ()
cycleUnless x g mp = let g' x' = doUnless mp (g' $ g x')
in g' $ g x
Aside: I feel like fix could be used to make the above neater, though I still have trouble working out how to use it
But cycleUnless won't work on foobar because the type of foobar' is actually Int -> IO () (from the use of print x').
I'd also like to take this abstraction further, so that it can work threading around a Monad. With stateful Monads it becomes even harder. E.g.
-- EDIT: Updated the below to show an example of how the code is used
{- ^^ some parent function which has the MVar ^^ -}
cycleST :: (forall s. ST s (STArray s Int Int)) -> IO ()
cycleST sta = readMVar mvb >>= \b -> unless b $ do
n <- readMVar someMVar
i <- readMVar someOtherMVar
let sta' = do
arr <- sta
x <- readArray arr n
writeArray arr n (x + i)
return arr
y = runSTArray sta'
print y
cycleST sta'
I have something similar to the above working with RankNTypes. Now there's the additional problem of trying to thread through the existential s, which is not likely to type check if threaded around through an abstraction the likes of cycleUnless.
Additionally, this is simplified to make the question easier to answer. I also use a set of semaphores built from MVar [MVar ()] similar to the skip channel example in the MVar module. If I can solve the above problem I plan to generalize the semaphores as well.
Ultimately this isn't some blocking problem. I have 3 components of the application operating in a cycle off the same MVar Bool but doing fairly different asynchronous tasks. In each one I have written a custom function that performs the appropriate cycle.
I'm trying to learn the "don't write large programs" approach. What I'd like to do is refactor chunks of code into their own mini libraries so that I'm not building a large program but assembling lots of small ones. But so far this particular abstraction is escaping me.
Any thoughts on how I might go about this are very much appreciated!
You want to cleanly combine a stateful action having side effects, a delay, and an independent stopping condition.
The iterative monad transformer from the free package can be useful in these cases.
This monad transformer lets you describe a (possibly nonending) computation as a series of discrete steps. And what's better, it let's you interleave "stepped" computations using mplus. The combined computation stops when any of the individual computations stops.
Some preliminary imports:
import Data.Bool
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Iter (delay,untilJust,IterT,retract,cutoff)
import Control.Concurrent
Your foobar function could be understood as a "sum" of three things:
A computation that does nothing but reading from the MVar at each step, and finishes when the Mvar is True.
untilTrue :: (MonadIO m) => MVar Bool -> IterT m ()
untilTrue = untilJust . liftM guard . liftIO . readMVar
An infinite computation that takes a delay at each step.
delays :: (MonadIO m) => Int -> IterT m a
delays = forever . delay . liftIO . threadDelay
An infinite computation that prints an increasing series of numbers.
foobar' :: (MonadIO m) => Int -> IterT m a
foobar' x = do
let x' = x + 1
liftIO (print x')
delay (foobar' x')
With this in place, we can write foobar as:
foobar :: (MonadIO m) => MVar Bool -> m ()
foobar v = retract (delays 1000000 `mplus` untilTrue v `mplus` foobar' 0)
The neat thing about this is that you can change or remove the "stopping condition" and the delay very easily.
Some clarifications:
The delay function is not a delay in IO, it just tells the iterative monad transformer to "put the argument in a separate step".
retract brings you back from the iterative monad transformer to the base monad. It's like saying "I don't care about the steps, just run the computation". You can combine retract with cutoff if you want to limit the maximum number of iterations.
untilJustconverts a value m (Maybe a) of the base monad into a IterT m a by retrying in each step until a Just is returned. Of course, this risks non-termination!
MPredicate is rather superfluous here; m Bool can be used instead. The monad-loops package contains plenty of control structures with m Bool conditions. whileM_ in particular is applicable here, although we need to include a State monad for the Int that we're threading around:
import Control.Monad.State
import Control.Monad.Loops
import Control.Applicative
foobar :: MVar Bool -> IO ()
foobar mvb = (`evalStateT` (0 :: Int)) $
whileM_ (not <$> lift (readMVar mvb)) $ do
modify (+1)
lift . print =<< get
lift $ threadDelay 1000000
Alternatively, we can use a monadic version of unless. For some reason monad-loops doesn't export such a function, so let's write it:
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mb action = do
b <- mb
unless b action
It's somewhat more convenient and more modular in a monadic setting, since we can always go from a pure Bool to m Bool, but not vice versa.
foobar :: MVar Bool -> IO ()
foobar mvb = go 0
where
go :: Int -> IO ()
go x = unlessM (readMVar mvb) $ do
let x' = x + 1
print x'
threadDelay 1000000
go x'
You mentioned fix; sometimes people indeed use it for ad-hoc monadic loops, for example:
printUntil0 :: IO ()
printUntil0 =
putStrLn "hello"
fix $ \loop -> do
n <- fmap read getLine :: IO Int
print n
when (n /= 0) loop
putStrLn "bye"
With some juggling it's possible to use fix with multi-argument functions. In the case of foobar:
foobar :: MVar Bool -> IO ()
foobar mvb = ($(0 :: Int)) $ fix $ \loop x -> do
unlessM (readMVar mvb) $ do
let x' = x + 1
print x'
threadDelay 1000000
loop x'
I'm not sure what's your MPredicate is doing.
First, instead of newtyping a tuple, it's probably better to use a normal algebric data type
data MPredicate a m = MPredicate a (a -> m Bool)
Second, the way you use it, MPredicate is equivalent to m Bool.
Haskell is lazzy, therefore there is no need to pass, a function and it's argument (even though
it's usefull with strict languages). Just pass the result, and the function will be called when needed.
I mean, instead of passing (x, f) around, just pass f x
Of course, if you are not trying to delay the evaluation and really need at some point, the argument or the function as well as the result, a tuple is fine.
Anyway, in the case your MPredicate is only there to delay the function evaluation, MPredicat reduces to m Bool and doUnless to unless.
Your first example is strictly equivalent :
main = do
b <- newMVar False
unless (readMVar b) (print "foo")
Now, if you want to loop a monad until a condition is reach (or equivalent) you should have a look at the monad-loop package. What you are looking it at is probably untilM_ or equivalent.
The current version of the Pipes tutorial, uses the following two functions in one of the example:
stdout :: () -> Consumer String IO r
stdout () = forever $ do
str <- request ()
lift $ putStrLn str
stdin :: () -> Producer String IO ()
stdin () = loop
where
loop = do
eof <- lift $ IO.hIsEOF IO.stdin
unless eof $ do
str <- lift getLine
respond str
loop
As is mentinoed in the tutorial itself, P.stdin is a bit more complicated due to the need to check for the end of input.
Are there any nice ways to rewrite P.stdin to not need a manual tail recursive loop and use higher order control flow combinators like P.stdout does? In an imperative language I would use a structured while loop or a break statement to do the same thing:
while(not IO.isEOF(IO.stdin) ){
str <- getLine()
respond(str)
}
forever(){
if(IO.isEOF(IO.stdin) ){ break }
str <- getLine()
respond(str)
}
I prefer the following:
import Control.Monad
import Control.Monad.Trans.Either
loop :: (Monad m) => EitherT e m a -> m e
loop = liftM (either id id) . runEitherT . forever
-- I'd prefer 'break', but that's in the Prelude
quit :: (Monad m) => e -> EitherT e m r
quit = left
You use it like this:
import Pipes
import qualified System.IO as IO
stdin :: () -> Producer String IO ()
stdin () = loop $ do
eof <- lift $ lift $ IO.hIsEOF IO.stdin
if eof
then quit ()
else do
str <- lift $ lift getLine
lift $ respond str
See this blog post where I explain this technique.
The only reason I don't use that in the tutorial is that I consider it less beginner-friendly.
Looks like a job for whileM_:
stdin () = whileM_ (lift . fmap not $ IO.hIsEOF IO.stdin) (lift getLine >>= respond)
or, using do-notation similarly to the original example:
stdin () =
whileM_ (lift . fmap not $ IO.hIsEOF IO.stdin) $ do
str <- lift getLine
respond str
The monad-loops package offers also whileM which returns a list of intermediate results instead of ignoring the results of the repeated action, and other useful combinators.
Since there is no implicit flow there is no such thing like "break". Moreover your sample already is small block which will be used in more complicated code.
If you want to stop "producing strings" it should be supported by your abstraction. I.e. some "managment" of "pipes" using special monad in Consumer and/or other monads that related with this one.
You can simply import System.Exit, and use exitWith ExitSuccess
Eg. if (input == 'q')
then exitWith ExitSuccess
else print 5 (anything)
I'm going to be writing a real-time game in Haskell using netwire and OpenGL. The basic idea is that each object will be represented by a wire, which will get some amount of data as input and output its state, and then I'll hook it all up into one big wire that gets the state of the GUI as input and outputs the world state, which I can then pass onto a renderer as well as some 'global' logic like collision detection.
One thing I'm not sure about is: how do I want to type the wires? Not all entities have the same input; the player is the only entity that can access the state of the key input, seeking missiles need the position of their target, etc.
One idea would be to have an ObjectInput type that gets passed to everything, but that seems bad to me since I could accidentally introduce dependencies I don't want.
On the other hand, I don't know if having a SeekerWire, a PlayerWire, an EnemyWire, etc., would be a good idea since they're almost 'identical' and so I'd have to duplicate functionality across them.
What should I do?
The inhibition monoid e is the type for inhibition exceptions. It's not something the wire produces, but takes about the same role as the e in Either e a. In other words, if you combine wires by <|>, then the output types must be equal.
Let's say your GUI events are passed to the wire through input and you have a continuous key-down event. One way to model this is the most straightforward:
keyDown :: (Monad m, Monoid e) => Key -> Wire e m GameState ()
This wire takes the current game state as input and produces a () if the key is held down. While the key is not pressed, it simply inhibits. Most applications don't really care about why a wire inhibits, so most wires inhibit with mempty.
A much more convenient way to express this event is by using a reader monad:
keyDown :: (Monoid e) => Key -> Wire e (Reader GameState) a a
What's really useful about this variant is that now you don't have to pass the game state as input. Instead this wire just acts like the identity wire when the even happens and inhibits when it doesn't:
quitScreen . keyDown Escape <|> mainGame
The idea is that when the escape key is pressed, then the event wire keyDown Escape vanishes temporarily, because it acts like the identity wire. So the whole wire acts like quitScreen assuming that it doesn't inhibit itself. Once the key is released, the event wire inhibits, so the composition with quitScreen inhibits, too. Thus the whole wire acts like mainGame.
If you want to limit the game state a wire can see, you can easily write a wire combinator for that:
trans :: (forall a. m' a -> m a) -> Wire e m' a b -> Wire e m a b
This allows you to apply withReaderT:
trans (withReaderT fullGameStateToPartialGameState)
There is a very simple and general solution to this. The key idea is that you never merge sources of different types. Instead, you only merge sources of the same type. The trick that makes this work is that you wrap the output of all your diverse sources in an algebraic data type.
I'm not really familiar with netwire, so if you don't mind I will use pipes as the example. What we want is a merge function that takes a list of sources and combines them into a single source that merges their outputs concurrently, finishing when they all complete. The key type signature is:
merge
:: (Proxy p)
=> [() -> Producer ProxyFast a IO r] -> () -> Producer p a IO ()
That just says that it takes a list of Producers of values of type a, and combines them into a single Producer of values of type a. Here's the implementation of merge, if you are curious and you want to follow along:
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Monad
import Control.Proxy
fromNChan :: (Proxy p) => Int -> Chan (Maybe a) -> () -> Producer p a IO ()
fromNChan n0 chan () = runIdentityP $ loop n0 where
loop 0 = return ()
loop n = do
ma <- lift $ readChan chan
case ma of
Nothing -> loop (n - 1)
Just a -> do
respond a
loop n
toChan :: (Proxy p) => Chan ma -> () -> Consumer p ma IO r
toChan chan () = runIdentityP $ forever $ do
ma <- request ()
lift $ writeChan chan ma
merge
:: (Proxy p)
=> [() -> Producer ProxyFast a IO r] -> () -> Producer p a IO ()
merge producers () = runIdentityP $ do
chan <- lift newChan
lift $ forM_ producers $ \producer -> do
let producer' () = do
(producer >-> mapD Just) ()
respond Nothing
forkIO $ runProxy $ producer' >-> toChan chan
fromNChan (length producers) chan ()
Now, let's imagine that we have two sources of input. The first one generates the integers from 1 to 10 in one second intervals:
throttle :: (Proxy p) => Int -> () -> Pipe p a a IO r
throttle microseconds () = runIdentityP $ forever $ do
a <- request ()
respond a
lift $ threadDelay microseconds
source1 :: (Proxy p) => () -> Producer p Int IO ()
source1 = enumFromS 1 10 >-> throttle 1000000
The second source reads three Strings from user input:
source2 :: (Proxy p) => () -> Producer p String IO ()
source2 = getLineS >-> takeB_ 3
We want to combine these two sources, but their output types don't match, so we define an algebraic data type to unify their outputs into a single type:
data Merge = UserInput String | AutoInt Int deriving Show
Now we can combine them into a single list of identically typed producers by wrapping their outputs in our algebraic data type:
producers :: (Proxy p) => [() -> Producer p Merge IO ()]
producers =
[ source1 >-> mapD UserInput
, source2 >-> mapD AutoInt
]
And we can test it out really quickly:
>>> runProxy $ merge producers >-> printD
AutoInt 1
Test<Enter>
UserInput "Test"
AutoInt 2
AutoInt 3
AutoInt 4
AutoInt 5
Apple<Enter>
UserInput "Apple"
AutoInt 6
AutoInt 7
AutoInt 8
AutoInt 9
AutoInt 10
Banana<Enter>
UserInput "Banana"
>>>
Now you have a combined source. You can then write your game engine to just read from that source, pattern match on the input and then behave appropriately:
engine :: (Proxy p) => () -> Consumer p Merge IO ()
engine () = runIdentityP loop where
loop = do
m <- request ()
case m of
AutoInt n -> do
lift $ putStrLn $ "Generate unit wave #" ++ show n
loop
UserInput str -> case str of
"quit" -> return ()
_ -> loop
Let's try it:
>>> runProxy $ merge producers >-> engine
Generate unit wave #1
Generate unit wave #2
Generate unit wave #3
Test<Enter>
Generate unit wave #4
quit<Enter>
>>>
I imagine the same trick will work for netwire.
Elm has a library for Automatons which I believe is similar to what you are doing.
You could use a typeclass for each type of state you want something to have access to. Then implement each of those classes for the entire state of your game (Assuming you have 1 big fat object holding everything).
-- bfgo = Big fat game object
class HasUserInput bfgo where
mouseState :: bfgo -> MouseState
keyState :: bfgo -> KeyState
class HasPositionState bfgo where
positionState :: bfgo -> [Position] -- Use your data structure
Then when you create the functions for using the data, you simply specify the typeclasses those functions will be using.
{-#LANGUAGE RankNTypes #-}
data Player i = Player
{playerRun :: (HasUserInput i) => (i -> Player i)}
data Projectile i = Projectile
{projectileRun :: (HasPositionState i) => (i -> Projectile i)}