Nested States in Haskell - haskell

I am trying to define a family of state machines with somewhat different kinds of states. In particular, the more "complex" state machines have states which are formed by combining the states of simpler state machines.
(This is similar to an object oriented setting where an object has several attributes which are also objects.)
Here is a simplified example of what I want to achieve.
data InnerState = MkInnerState { _innerVal :: Int }
data OuterState = MkOuterState { _outerTrigger :: Bool, _inner :: InnerState }
innerStateFoo :: Monad m => StateT InnerState m Int
innerStateFoo = do
i <- _innerVal <$> get
put $ MkInnerState (i + 1)
return i
outerStateFoo :: Monad m => StateT OuterState m Int
outerStateFoo = do
b <- _outerTrigger <$> get
if b
then
undefined
-- Here I want to "invoke" innerStateFoo
-- which should work/mutate things
-- "as expected" without
-- having to know about the outerState it
-- is wrapped in
else
return 666
More generally, I want a generalized framework where these nestings are more complex. Here is something I wish to know how to do.
class LegalState s
data StateLess
data StateWithTrigger where
StateWithTrigger :: LegalState s => Bool -- if this trigger is `True`, I want to use
-> s -- this state machine
-> StateWithTrigger
data CombinedState where
CombinedState :: LegalState s => [s] -- Here is a list of state machines.
-> CombinedState -- The combinedstate state machine runs each of them
instance LegalState StateLess
instance LegalState StateWithTrigger
instance LegalState CombinedState
liftToTrigger :: Monad m, LegalState s => StateT s m o -> StateT StateWithTrigger m o
liftToCombine :: Monad m, LegalState s => [StateT s m o] -> StateT CombinedState m o
For context, this is what I want to achieve with this machinery:
I want to design these things called "Stream Transformers", which are basically stateful functions: They consume a token, mutate their internal state and output something. Specifically, I am interested in a class of Stream Transformers where the output is a Boolean value; we will call these "monitors".
Now, I am trying to design combinators for these objects. Some of them are:
A pre combinator. Suppose that mon is a monitor. Then, pre mon is a monitor which always produces False after the first token is consumed and then mimicks the behaviour of mon as if the previous token is being inserted now. I would want to model the state of pre mon with StateWithTrigger in the example above since the new state is a boolean along with the original state.
An and combinator. Suppose that m1 and m2 are monitors. Then, m1 `and` m2 is a monitor which feeds the token to m1, and then to m2, and then produces True if both of the answers were true. I would want to model the state of m1 `and` m2 with CombinedState in the example above since the state of both monitors must be maintained.

For your first question, as Carl mentioned, zoom from lens does exactly what you want. Your code with lenses could be written like this:
{-# LANGUAGE TemplateHaskell #-}
import Control.Lens
import Control.Monad.State.Lazy
newtype InnerState = MkInnerState { _innerVal :: Int }
deriving (Eq, Ord, Read, Show)
data OuterState = MkOuterState
{ _outerTrigger :: Bool
, _inner :: InnerState
} deriving (Eq, Ord, Read, Show)
makeLenses ''InnerState
makeLenses ''OuterState
innerStateFoo :: Monad m => StateT InnerState m Int
innerStateFoo = do
i <- gets _innerVal
put $ MkInnerState (i + 1)
return i
outerStateFoo :: Monad m => StateT OuterState m Int
outerStateFoo = do
b <- gets _outerTrigger
if b
then zoom inner $ innerStateFoo
else pure 666
Edit: While we're at it, if you're already bringing in lens then innerStateFoo can be written like so:
innerStateFoo :: Monad m => StateT InnerState m Int
innerStateFoo = innerVal <<+= 1

For context, this is what I want to achieve with this machinery:
I want to design these things called "Stream Transformers", which are basically stateful functions: They consume a token, mutate their internal state and output something. Specifically, I am interested in a class of Stream Transformers where the output is a Boolean value; we will call these "monitors".
I think that what you want to achieve doesn't need very much machinery.
newtype StreamTransformer input output = StreamTransformer
{ runStreamTransformer :: input -> (output, StreamTransformer input output)
}
type Monitor input = StreamTransformer input Bool
pre :: Monitor input -> Monitor input
pre st = StreamTransformer $ \i ->
-- NB: the first output of the stream transformer vanishes.
-- Is that OK? Maybe this representation doesn't fit the spec?
let (_, st') = runStreamTransformer st i
in (False, st')
and :: Monitor input -> Monitor input -> Monitor input
and left right = StreamTransformer $ \i ->
let (bleft, mleft) = runStreamTransformer left i
(bright, mright) = runStreamTransformer right i
in (bleft && bright, mleft `and` mright)
This StreamTransformer is not necessarily stateful, but admits stateful ones. You don't need to (and IMO should not! in most cases!!) reach for typeclasses in order to define these (or indeed ever! :) but that's another topic).
notStateful :: StreamTransformer input ()
notStateful = StreamTransformer $ \_ -> ((), notStateful)
stateful :: s -> (input -> s -> (output, s)) -> StreamTransformer input output
stateful s k = StreamTransformer $ \input ->
let (output, s') = k input s
in (output, stateful s' k)
alternateBool :: Monitor anything
alternateBool = stateful True $ \_ s -> (s, not s)

Related

Using a Monadic eDSL from the REPL

Say I have created myself an embedded domain specific language in Haskell using a monad. For example a simple language that lets you push and pop values on a stack, implemented using the state monad:
type DSL a = State [Int] a
push :: Int -> DSL ()
pop :: DSL Int
Now I can write small stack manipulation programs using do notation:
program = do
push 10
push 20
a <- pop
push (5*a)
return a
However, I would really like to use my DSL interactively from a REPL (GHCi in particular, willing to use other if it would help).
Unfortunately having a session like:
>push 10
>pop
10
>push 100
Does not immediately work, which is probably rather reasonable. However I really think being able to do something with a similar feel to that would be cool. The way the state monad work does not lend itself easily to this. You need to build up your DSL a type and then evaluate it.
Is there a way to do something like this. Incrementally using a monad in the REPL?
I have been looking at things like operational, MonadPrompt, and MonadCont which I sort of get the feeling maybe could be used to do something like this. Unfortunately none of the examples I have seen addresses this particular problem.
Another possibility is to re-simulate the whole history each time you do anything. This will work for any pure monad. Here's an extemporaneous library for it:
{-# LANGUAGE RankNTypes #-}
import Data.IORef
import Data.Proxy
newtype REPL m f = REPL { run :: forall a. m a -> IO (f a) }
newREPL :: (Monad m) => Proxy m -> (forall a. m a -> f a) -> IO (REPL m f)
newREPL _ runM = do
accum <- newIORef (return ())
return $ REPL (\nextAction -> do
actions <- readIORef accum
writeIORef accum (actions >> nextAction >> return ())
return (runM (actions >> nextAction)))
Basically, it stores all the actions run thus far in an IORef, and each time you do something it adds to the list of actions and runs it from the top.
To create a repl, use newREPL, passing it a Proxy for the monad and a "run" function that gets you out of the monad. The reason the run function has type m a -> f a instead of m a -> a is so that you can include extra information in the output -- for example, you might want to view the current state, too, in which case you could use an f like:
data StateOutput a = StateOutput a [Int]
deriving (Show)
But I have just used it with Identity which does nothing special.
The Proxy argument is so that ghci's defaulting doesn't bite us when we create a new repl instance.
Here's how you use it:
>>> repl <- newREPL (Proxy :: Proxy DSL) (\m -> Identity (evalState m []))
>>> run repl $ push 1
Identity ()
>>> run repl $ push 2
Identity ()
>>> run repl $ pop
Identity 2
>>> run repl $ pop
Identity 1
If the extra Identity line noise bothers you, you could use your own functor:
newtype LineOutput a = LineOutput a
instance (Show a) => Show (LineOutput a) where
show (LineOutput x) = show x
There was one small change I had to make -- I had to change
type DSL a = State [Int] a
to
type DSL = State [Int]
because you can't use type synonyms that are not fully applied, like when I said Proxy :: DSL. The latter, I think, is more idiomatic anyway.
To an extent.
I don't believe it can be done for arbitrary Monads/instruction sets, but here's something that would work for your example. I'm using operational with an IORef to back the REPL state.
data DSLInstruction a where
Push :: Int -> DSLInstruction ()
Pop :: DSLInstruction Int
type DSL a = Program DSLInstruction a
push :: Int -> DSL ()
push n = singleton (Push n)
pop :: DSL Int
pop = singleton Pop
-- runDslState :: DSL a -> State [Int] a
-- runDslState = ...
runDslIO :: IORef [Int] -> DSL a -> IO a
runDslIO ref m = case view m of
Return a -> return a
Push n :>>= k -> do
modifyIORef ref (n :)
runDslIO ref (k ())
Pop :>>= k -> do
n <- atomicModifyIORef ref (\(n : ns) -> (ns, n))
runDslIO ref (k n)
replSession :: [Int] -> IO (Int -> IO (), IO Int)
replSession initial = do
ref <- newIORef initial
let pushIO n = runDslIO ref (push n)
popIO = runDslIO ref pop
(pushIO, popIO)
Then you can use it like:
> (push, pop) <- replSession [] -- this shadows the DSL push/pop definitions
> push 10
> pop
10
> push 100
It should be straightforward to use this technique for State/Reader/Writer/IO-based DSLs. I don't expect it to work for everything though.

"Persistently" Impure (IO) Vectors in Haskell, with database-like persistent interface

I have a computation that is best described as iterative mutations on a vector; the final result is the final state of the vector.
The "idiomatic" approach to making this functional, I think, is to simply pass on a new vector object along whenever it is "modified". So your iterative method would be operate_on_vector :: Vector -> Vector, which takes in a vector and outputs the modified vector, which is then fed through the method again.
This method is pretty straightforward and I had no problems implementing it, even being new to Haskell.
Alternatively, one could encapsulate all of this in a State monad and pass along a constantly re-created and modified vector as the state value.
However, I suffer a huge, huge performance cost, as these calculations are pretty intensive, the iterations many (on the order of millions) and the data vectors can get pretty large (on the order of at least thousands of primitives). Re-creating a new vector in memory at every step of the iteration seems pretty costly, data collection or not.
Then I considered how IO works -- it can be seen as basically like State, except the state value is the "World", which is constantly changing.
Maybe I could use something that is like IO to "operate" on a "world"? And the "world" would be the vector in-memory? Sort of like a database query, but everything is in memory.
For example with io you could do
do
putStrLn "enter something"
something <- getLine
putStrLine $ "you entered " ++ something
which can be seen as "performing" putStrLn and "modifying" the World object, returning a new World object and feeding it into the next function, which queryies the world object for a string that is the result of the modification, and then returns another world object after another modification.
Is there anything like that that can do this for mutable vectors?
do
putInVec 0 9 -- index 0, value 9
val <- getFromVec 0
putInVec 0 (val + 1)
, with "impure" "mutable" vectors, instead of passing along a new modified vector at each step.
I believe you can do this using mutable vector and a thin wrapper over Reader + ST (or IO) monad.
It can look like this:
type MyVector = IOVector $x -- Use your own elements type here instead of $x
newtype VectorIO a = VectorIO (ReaderT MyVector IO a) deriving (Monad, MonadReader, MonadIO)
-- You will need GeneralizedNewtypeDeriving extension here
-- Run your computation over an existing vector
runComputation :: MyVector -> VectorIO a -> IO MyVector
runComputation vector (VectorIO action) = runReaderT action vector >> return vector
-- Run your computation over a new vector of the specified length
runNewComputation :: Int -> VectorIO a -> IO MyVector
runNewComputation n action = do
vector <- new n
runComputation vector action
putInVec :: Int -> $x -> VectorIO ()
putInVec idx val = do
v <- ask
liftIO $ write v idx val
getFromVec :: Int -> VectorIO $x
getFromVec idx = do
v <- ask
liftIO $ read v idx
That's really all. You can use VectorIO monad to perform your computations, just like you wanted in your example. If you do not want IO but want pure computations, you can use ST monad; modifications to the code above will be trivial.
Update
Here is an ST-based version:
{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, Rank2Types #-}
module Main where
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Reader
import Control.Monad.Reader.Class
import Control.Monad.ST
import Data.Vector as V
import Data.Vector.Mutable as MV
-- Your type of the elements
type E = Int
-- Mutable vector which will be used as a context
type MyVector s = MV.STVector s E
-- Immutable vector compatible with MyVector in its type
type MyPureVector = V.Vector E
-- Simple monad stack consisting of a reader with the mutable vector as a context
-- and of an ST action
newtype VectorST s a = VectorST (ReaderT (MyVector s) (ST s) a) deriving Monad
-- Make the VectorST a reader monad
instance MonadReader (MyVector s) (VectorST s) where
ask = VectorST $ ask
local f (VectorST a) = VectorST $ local f a
reader = VectorST . reader
-- Lift an ST action to a VectorST action
liftST :: ST s a -> VectorST s a
liftST = VectorST . lift
-- Run your computation over an existing vector
runComputation :: MyVector s -> VectorST s a -> ST s (MyVector s)
runComputation vector (VectorST action) = runReaderT action vector >> return vector
-- Run your computation over a new vector of the specified length
runNewComputation :: Int -> VectorST s a -> ST s (MyVector s)
runNewComputation n action = do
vector <- MV.new n
runComputation vector action
-- Run a computation on a new mutable vector and then freeze it to an immutable one
runComputationPure :: Int -> (forall s. VectorST s a) -> MyPureVector
runComputationPure n action = runST $ do
vector <- runNewComputation n action
V.unsafeFreeze vector
-- Put an element into the current vector
putInVec :: Int -> E -> VectorST s ()
putInVec idx val = do
v <- ask
liftST $ MV.write v idx val
-- Retrieve an element from the current vector
getFromVec :: Int -> VectorST s E
getFromVec idx = do
v <- ask
liftST $ MV.read v idx

Applying Semantics to Free Monads

I am trying to abstract the pattern of applying a certain semantics to a free monad over some functor. The running example I am using to motivate this is applying updates to an entity in a game. So I import a few libraries and define a few example types and an entity class for the purposes of this example (I am using the free monad implementation in control-monad-free):
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
import Control.Monad.Free
import Control.Monad.Identity
import Control.Monad.Writer
-- Things which can happen to an entity
data Order = Order deriving Show
data Damage = Damage deriving Show
class Entity a where
evolve :: Double -> a -> a
order :: Order -> a -> a
damage :: Damage -> a -> a
-- Make a trivial entity for testing purposes
data Example = Example deriving Show
instance Entity Example where
evolve _ a = a
order _ a = a
damage _ a = a
-- A type to hold all the possible update types
data EntityUpdate =
UpdateTime Double
| UpdateOrder Order
| UpdateDamage Damage
deriving (Show)
-- Wrap UpdateMessage to create a Functor for constructing the free monad
data UpdateFunctor cont =
UpdateFunctor {updateMessage :: EntityUpdate, continue :: cont} deriving (Show, Functor)
-- Type synonym for the free monad
type Update = Free UpdateEntity
I now lift some basic updates into the monad:
liftF = wrap . fmap Pure
updateTime :: Double -> Update ()
updateTime t = liftUpdate $ UpdateTime t
updateOrder :: Order -> Update ()
updateOrder o = liftUpdate $ UpdateOrder o
updateDamage :: Damage -> Update ()
updateDamage d = liftUpdate $ UpdateDamage d
test :: Update ()
test = do
updateTime 8.0
updateOrder Order
updateDamage Damage
updateTime 4.0
updateDamage Damage
updateTime 6.0
updateOrder Order
updateTime 8.0
Now we have the free monad, we need to provide the possibility of different implementations, or semantic interpretations, of monad instance such as test above. The best pattern I can come up with for this is given by the following function:
interpret :: (Monad m, Functor f, fm ~ Free f c) => (f fm -> fm) -> (f fm -> a -> m a) -> fm -> a -> m a
interpret _ _ (Pure _ ) entity = return entity
interpret c f (Impure u) entity = f u entity >>= interpret c f (c u)
Then with some basic semantic functions we can give the two following possible interpretations, one as a basic evaluation and one as a writer monad preforming logging:
update (UpdateTime t) = evolve t
update (UpdateOrder o) = order o
update (UpdateDamage d) = damage d
eval :: Entity a => Update () -> a -> a
eval updates entity = runIdentity $ interpret continue update' updates entity where
update' u entity = return $ update (updateMessage u) entity
logMessage (UpdateTime t) = "Simulating time for " ++ show t ++ " seconds.\n"
logMessage (UpdateOrder o) = "Giving an order.\n"
logMessage (UpdateDamage d) = "Applying damage.\n"
evalLog :: Entity a => Update () -> a -> Writer String a
evalLog = interpret continue $ \u entity -> do
let m = updateMessage u
tell $ logMessage m
return $ update m entity
Testing this in GHCI:
> eval test Example
Example
> putStr . execWriter $ evalLog test Example
Simulating time for 8.0 seconds.
Giving an order.
Applying damage.
Simulating time for 4.0 seconds.
Applying damage.
Simulating time for 6.0 seconds.
Giving an order.
Simulating time for 8.0 seconds.
This all works fine, but it gives me a slightly uneasy feeling that it could be more general, or could be better organised. Having to provide a function to provide the continuation wasn't obvious at first and I'm not sure it is the best approach. I have made several efforts to redefine interpret in terms of functions in the Control.Monad.Free module, such as foldFree and induce. But they all seem to not quite work.
Am I on the right lines with this, or am a making a misjudgement? Most of the articles on free monads I have found concentrate on their efficiency or different ways to implement them, rather than on patterns for actually using them like this.
It also seems desirable to encapsulate this in some kind of Semantic class, so I could simply make different monad instances from my free monad by wrapping the functor in a newtype and making it an instance of this class. I couldn't quite work out how to do this however.
UPDATE --
I wish I could have accepted both answers as they are both extremely informative and thoughtfully written. In the end though, the edit to the accepted answer contains the function I was after:
interpret :: (Functor m, Monad m) => (forall x. f x -> m x) -> Free f a -> m a
interpret evalF = retract . hoistFree evalF
(retract and hoistFree are in Edward Kemmet's free package in Control.Monad.Free).
All three of pipes, operational and sacundim's free-operational package are very relevant and look like they will be very useful for me in the future. Thank you all.
You can use my pipes library, which provides higher level abstractions for working with free monads.
pipes uses free monads to reify every part of the computation:
The Producer of data (i.e. your update) is a free monad
The Consumer of data (i.e. your interpreter) is a free monad
The Pipe of data (i.e. your logger) is a free monad
In fact, they are not three separate free monads: they are all the same free monad in disguise. Once you define all three of them you connect them using pipe composition, (>->), in order to start streaming data.
I'll begin with a slightly modified version of your example that skips the type class you wrote:
{-# LANGUAGE RankNTypes #-}
import Control.Lens
import Control.Proxy
import Control.Proxy.Trans.State
import Control.Monad.Trans.Writer
data Order = Order deriving (Show)
data Damage = Damage deriving (Show)
data EntityUpdate
= UpdateTime Double
| UpdateOrder Order
| UpdateDamage Damage
deriving (Show)
Now what we do is define an Update to be a Producer of EntityUpdates:
type Update r = forall m p . (Monad m, Proxy p) => Producer p EntityUpdate m r
Then we define the actual commands. Each command yields the corresponding update using the respond pipe primitive, which sends the data further downstream for processing.
updateTime :: Double -> Update ()
updateTime t = respond (UpdateTime t)
updateOrder :: Order -> Update ()
updateOrder o = respond (UpdateOrder o)
updateDamage :: Damage -> Update ()
updateDamage d = respond (UpdateDamage d)
Since a Producer is a free monad, we can assemble it using do notation just like you did for your test function:
test :: () -> Update ()
-- i.e. () -> Producer p EntityUpdate m ()
test () = runIdentityP $ do
updateTime 8.0
updateOrder Order
updateDamage Damage
updateTime 4.0
updateDamage Damage
updateTime 6.0
updateOrder Order
updateTime 8.0
However, we can reify the interpreter as a Consumer of data, too. This is nice because we can then directly layer on state over the interpreter instead of using the Entity class you defined.
I'll use a simple state:
data MyState = MyState { _numOrders :: Int, _time :: Double, _health :: Int }
deriving (Show)
begin :: MyState
begin= MyState 0 0 100
... and define some convenient lenses for clarity:
numOrders :: Lens' MyState Int
numOrders = lens _numOrders (\s x -> s { _numOrders = x})
time :: Lens' MyState Double
time = lens _time (\s x -> s { _time = x })
health :: Lens' MyState Int
health = lens _health (\s x -> s { _health = x })
... and now I can define a stateful interpreter:
eval :: (Proxy p) => () -> Consumer (StateP MyState p) EntityUpdate IO r
eval () = forever $ do
entityUpdate <- request ()
case entityUpdate of
UpdateTime tDiff -> modify (time +~ tDiff)
UpdateOrder _ -> modify (numOrders +~ 1 )
UpdateDamage _ -> modify (health -~ 1 )
s <- get
lift $ putStrLn $ "Current state is: " ++ show s
That makes it much more clear what the interpreter is doing. We can see at a glance how it processes incoming values in a stateful way.
To connect our Producer and Consumer we use the (>->) composition operator, followed by runProxy, which transforms our pipeline back to the base monad:
main1 = runProxy $ evalStateK begin $ test >-> eval
... which produces the following result:
>>> main1
Current state is: MyState {_numOrders = 0, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 98}
Current state is: MyState {_numOrders = 1, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 26.0, _health = 98}
You might wonder why we have to do this in two steps. Why not just get rid of the runProxy part?
The reason why is that we may wish to compose more than two things. For example, we can very easily insert a logging stage in between test and eval. I call these intermediate stages Pipes:
logger
:: (Monad m, Proxy p)
=> () -> Pipe p EntityUpdate EntityUpdate (WriterT String m) r
logger () = runIdentityP $ forever $ do
entityUpdate <- request ()
lift $ tell $ case entityUpdate of
UpdateTime t -> "Simulating time for " ++ show t ++ " seconds.\n"
UpdateOrder o -> "Giving an order.\n"
UpdateDamage d -> "Applying damage.\n"
respond entityUpdate
Again, we can very clearly see what logger does: It requests a value, tells a representation of the value, and then passes the value further downstream using respond.
We can insert this in between test and logger. The only thing we must be aware of is that all stages must have the same base monad, so we use raiseK to insert a WriterT layer for eval so that it matches the base monad of logger:
main2 = execWriterT $ runProxy $ evalStateK begin $
test >-> logger >-> raiseK eval
... which produces the following result:
>>> main2
Current state is: MyState {_numOrders = 0, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 98}
Current state is: MyState {_numOrders = 1, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 26.0, _health = 98}
"Simulating time for 8.0 seconds.\nGiving an order.\nApplying damage.\nSimulating time for 4.0 seconds.\nApplying damage.\nSimulating time for 6.0 seconds.\nGiving an order.\nSimulating time for 8.0 seconds.\n"
pipes was designed to solve exactly the kind of problem you describe. A lot of the time we want to reify not only the DSL that generates the data, but the interpreters and intermediate processing stages, too. pipes treats all of these concepts identically and models all of them as connectable stream DSLs. This makes it very easy to swap in and out various behaviors without having to define your own custom interpreter framework.
If you are new to pipes, then you might want to check out the tutorial.
I don't quite understand your example, but I think you are basically reconstructing the operational package in here. Your EntityUpdate type is very much like an instruction set in the sense of operational, and your UpdateFunctor is something like the free functor over the instruction set—which is precisely the construction that relates operational and free monads. (See "Is operational really isomorphic to a free monad?" and this Reddit discussion).
But anyway, the operational package has the function you want, interpretWithMonad:
interpretWithMonad :: forall instr m b.
Monad m =>
(forall a. instr a -> m a)
-> Program instr b
-> m b
This allows you to provide a function that interprets each of the instructions in your program (each EntityUpdate value) as a monadic action, and takes care of the rest.
If I may be allowed a tad of self-promotion, I was just recently writing my own version of operational using free monads, because I wanted to have an Applicative version of operational's Program type. Since your example struck me as being purely applicative, I went through the exercise of writing your evalLog in terms of my library, and I might as well paste it here. (I couldn't understand your eval function.) Here goes:
{-# LANGUAGE GADTs, ScopedTypeVariables, RankNTypes #-}
import Control.Applicative
import Control.Applicative.Operational
import Control.Monad.Writer
data Order = Order deriving Show
data Damage = Damage deriving Show
-- UpdateI is short for "UpdateInstruction"
data UpdateI a where
UpdateTime :: Double -> UpdateI ()
UpdateOrder :: Order -> UpdateI ()
UpdateDamage :: Damage -> UpdateI ()
type Update = ProgramA UpdateI
updateTime :: Double -> Update ()
updateTime = singleton . UpdateTime
updateOrder :: Order -> Update ()
updateOrder = singleton . UpdateOrder
updateDamage :: Damage -> Update ()
updateDamage = singleton . UpdateDamage
test :: Update ()
test = updateTime 8.0
*> updateOrder Order
*> updateDamage Damage
*> updateTime 4.0
*> updateDamage Damage
*> updateTime 6.0
*> updateOrder Order
*> updateTime 8.0
evalLog :: forall a. Update a -> Writer String a
evalLog = interpretA evalI
where evalI :: forall x. UpdateI x -> Writer String x
evalI (UpdateTime t) =
tell $ "Simulating time for " ++ show t ++ " seconds.\n"
evalI (UpdateOrder Order) = tell $ "Giving an order.\n"
evalI (UpdateDamage Damage) = tell $ "Applying damage.\n"
Output:
*Main> putStr $ execWriter (evalLog test)
Simulating time for 8.0 seconds.
Giving an order.
Applying damage.
Simulating time for 4.0 seconds.
Applying damage.
Simulating time for 6.0 seconds.
Giving an order.
Simulating time for 8.0 seconds.
The trick here is the same as in the interpretWithMonad function from the original package, but adapted to applicatives:
interpretA :: forall instr f a. Applicative f =>
(forall x. instr x -> f x)
-> ProgramA instr a -> f a
If you truly need a monadic interpretation it's just a mater of importing Control.Monad.Operational (either the original one or mine) instead of Control.Applicative.Operational, and using Program instead of ProgramA. ProgramA however gives you greater power to examine the program statically:
-- Sum the total time requested by updateTime instructions in an
-- applicative UpdateI program. You can't do this with monads.
sumTime :: ProgramA UpdateI () -> Double
sumTime = sumTime' . viewA
where sumTime' :: forall x. ProgramViewA UpdateI x -> Double
sumTime' (UpdateTime t :<**> k) = t + sumTime' k
sumTime' (_ :<**> k) = sumTime' k
sumTime' (Pure _) = 0
Example usage of sumTime:
*Main> sumTime test
26.0
EDIT: In retrospect, I should have provided this shorter answer. This assumes you're using Control.Monad.Free from Edward Kmett's package:
interpret :: (Functor m, Monad m) =>
(forall x. f x -> m x)
-> Free f a -> m a
interpret evalF = retract . hoistFree evalF

Game entity modeling with netwire

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)}

What is the name of this Monad Stack function?

I've got a bunch of stateful functions inside a State monad. At one point in the program there needs to be some IO actions so I've wrapped IO inside a StateT getting a pair of types like this:
mostfunctions :: State Sometype a
toplevel :: StateT Sometype IO a
To keep things simple I don't want pass the IO context into the main set of functions and I would like to avoid wrapping them in the monad stack type. But in order to call them from the toplevel function I need something akin to a lift, but I'm not trying to lift a value from the inner monad. Rather I want to convert the state in the StateT monad into something equivalent in the State monad. To do this I've got the following:
wrapST :: (State Sometype a) -> StateT Sometype IO a
wrapST f = do s <- get
let (r,s2) = runState f s
put s2
return r
This then get used to interleave things like the following:
toplevel = do liftIO $ Some IO functions
wrapST $ Some state mutations
liftIO $ More IO functions
....
It seems like a fairly obvious block of code so I'm wondering does this function have a standard name, and it is already implemented somewhere in the standard libraries? I've tried to keep the description simple but obviously this extends to pulling one transformer out of a stack, converting the wrapped value to the cousin of the transformer type, skipping the monads below in the stack, and then pushing the results back in at the end.
It may be a good idea to refactor your code to use the type StateT SomeType m a instead of State SomeType a, because the first one is compatible to an arbitrary monad stack. If you'd change it like this, you don't need a function wrapST anymore, since you can call the stateful functions directly.
Okay. Suppose you have a function subOne :: Monad m => State Int Int:
subOne = do a <- get
put $ a - 1
return a
Now, change the types of all functions like this one from State SomeType a to StateT SomeType m a, leaving m as is. This way, your functions can work on any monadic stack. For those functions, that require IO, you can specify, that the monad at the bottom must be IO:
printState :: MonadIO m => StateT Int m ()
printState = do a <- get
liftIO $ print a
Now, it should be possible to use both functions together:
-- You could use me without IO as well!
subOne :: Monad m => StateT Int m ()
subOne = do a <- get
put $ a - 1
printState :: MonadIO m => StateT Int m ()
printState = do a <- get
liftIO $ print a
toZero :: StateT Int IO ()
toZero = do subOne -- A really pure function
printState -- function may perform IO
a <- get
when (a > 0) toZero
PS: I use GHC 7, some of the libs changed midway, so it might be a bit different on GHC 6.
A more direct answer to your question: the function hoist does exactly what you're describing in a slightly more generic way. Example usage:
import Control.Monad.State
import Data.Functor.Identity
import Control.Monad.Morph
foo :: State Int Integer
foo = put 1 >> return 1
bar :: StateT Int IO Integer
bar = hoist (return . runIdentity) foo
hoist is part of the MFunctor class, which is defined like this:
class MFunctor t where
hoist :: Monad m => (forall a. m a -> n a) -> t m b -> t n b
There are instances for most monad tranformers, but not ContT.

Resources