choosing a monad at runtime - haskell

I'm trying to write a two-player game in Haskell, such as checkers. I envision having types GameState, Move, and a function result :: GameState -> Move -> GameState that defines the game rules. I want to have both human and automated players, and I figured I'd do this by having a typeclass:
class Player p m | p -> m where
selectMove :: p -> GameState -> m Move
where the idea would be that m could be Identity for a basic AI player, IO for a human, State for an AI that maintains state across moves, etc. The question is how to go from these to the overall game loop. I figure I could define something like:
Player p1 m1, Player p2 m2 => moveList :: p1 -> p2 -> GameState -> m1 m2 [Move]
a monadic function that takes in the players and initial state, and returns the lazy list of moves. But then on top of this let's say I want a text-based interface that, say, allows first selecting each player from a list of possibilities, then causes the game to be played. So I'd need:
playGame :: IO ()
I can't see how to define playGame given moveList in a generic way. Or is my overall approach not right?
EDIT: thinking further about it, I don't even see how to define moveList above. E.g., if player 1 was a human, so IO, and player 2 was a stateful AI, so State, the first move of player 1 would have type IO Move. Then player 2 would have to take the resulting state of type IO GameState and produce a move of type State IO Move, and player 1's next move would be of type IO State IO Move? That doesn't look right.

There are two parts to this question:
How to mix a monad-independent chess-playing framework with incremental monad-specific input
How to specify the monad-specific part at run time
You solve the former problem using a generator, which is a special case of a free monad transformer:
import Control.Monad.Trans.Free -- from the "free" package
type GeneratorT a m r = FreeT ((,) a) m r
-- or: type Generator a = FreeT ((,) a)
yield :: (Monad m) => a -> GeneratorT a m ()
yield a = liftF (a, ())
GeneratorT a is a monad transformer (because FreeT f is a monad transformer, for free, when f is a Functor). This means we can mix yield (which is polymorphic in the base monad), with monad-specific calls by using lift to invoke the base monad.
I'll define some fake chess moves just for this example:
data ChessMove = EnPassant | Check | CheckMate deriving (Read, Show)
Now, I'll define an IO based generator of chess moves:
import Control.Monad
import Control.Monad.Trans.Class
ioPlayer :: GeneratorT ChessMove IO r
ioPlayer = forever $ do
lift $ putStrLn "Enter a move:"
move <- lift readLn
yield move
That was easy! We can unwrap the result one move at a time using runFreeT, which will only demand the player input a move when you bind the the result:
runIOPlayer :: GeneratorT ChessMove IO r -> IO r
runIOPlayer p = do
x <- runFreeT p -- This is when it requests input from the player
case x of
Pure r -> return r
Free (move, p') -> do
putStrLn "Player entered:"
print move
runIOPlayer p'
Let's test it:
>>> runIOPlayer ioPlayer
Enter a move:
EnPassant
Player entered:
EnPassant
Enter a move:
Check
Player entered:
Check
...
We can do the same thing using the Identity monad as the base monad:
import Data.Functor.Identity
type Free f r = FreeT f Identity r
runFree :: (Functor f) => Free f r -> FreeF f r (Free f r)
runFree = runIdentity . runFreeT
NoteThe transformers-free packages defines these already (Disclaimer: I wrote it and Edward merged its functionality was merged into the free package. I only keep it for teaching purposes and you should use free if possible).
With those in hand, we can define pure chess move generators:
type Generator a r = Free ((,) a) r
-- or type Generator a = Free ((,) a)
purePlayer :: Generator ChessMove ()
purePlayer = do
yield Check
yield CheckMate
purePlayerToList :: Generator ChessMove r -> [ChessMove]
purePlayerToList p = case (runFree p) of
Pure _ -> []
Free (move, p') -> move:purePlayerToList p'
purePlayerToIO :: Generator ChessMove r -> IO r
purePlayerToIO p = case (runFree p) of
Pure r -> return r
Free (move, p') -> do
putStrLn "Player entered: "
print move
purePlayerToIO p'
Let's test it:
>>> purePlayerToList purePlayer
[Check, CheckMate]
Now, to answer your next question, which is how to choose the base monad at run time. This is easy:
main = do
putStrLn "Pick a monad!"
whichMonad <- getLine
case whichMonad of
"IO" -> runIOPlayer ioPlayer
"Pure" -> purePlayerToIO purePlayer
"Purer!" -> print $ purePlayerToList purePlayer
Now, here is where things get tricky. You actually want two players, and you want to specify the base monad for both of them independently. To do this, you need a way to retrieve one move from each player as an action in the IO monad and save the rest of the player's move list for later:
step
:: GeneratorT ChessMove m r
-> IO (Either r (ChessMove, GeneratorT ChessMove m r))
The Either r part is in case the player runs out of moves (i.e. reaches the end of their monad), in which case the r is the block's return value.
This function is specific to each monad m, so we can type class it:
class Step m where
step :: GeneratorT ChessMove m r
-> IO (Either r (ChessMove, GeneratorT ChessMove m r))
Let's define some instances:
instance Step IO where
step p = do
x <- runFreeT p
case x of
Pure r -> return $ Left r
Free (move, p') -> return $ Right (move, p')
instance Step Identity where
step p = case (runFree p) of
Pure r -> return $ Left r
Free (move, p') -> return $ Right (move, p')
Now, we can write our game loop to look like:
gameLoop
:: (Step m1, Step m2)
=> GeneratorT ChessMove m1 a
-> GeneratorT ChessMove m2 b
-> IO ()
gameLoop p1 p2 = do
e1 <- step p1
e2 <- step p2
case (e1, e2) of
(Left r1, _) -> <handle running out of moves>
(_, Left r2) -> <handle running out of moves>
(Right (move1, p2'), Right (move2, p2')) -> do
<do something with move1 and move2>
gameLoop p1' p2'
And our main function just selects which players to use:
main = do
p1 <- getStrLn
p2 <- getStrLn
case (p1, p2) of
("IO", "Pure") -> gameLoop ioPlayer purePlayer
("IO", "IO" ) -> gameLoop ioPlayer ioPlayer
...
I hope that helps. That was probably a bit over kill (and you can probably use something simpler than generators), but I wanted to give a general tour of cool Haskell idioms that you can sample from when designing your game. I type-checked all but the last few code blocks, since I couldn't come up with a sensible game logic to test on the fly.
You can learn more about free monads and free monad transformers if those examples didn't suffice.

My advice has two main parts:
Skip defining a new type class.
Program to the interfaces defined by existing type classes.
For the first part, what I mean is you should consider creating a data type like
data Player m = Player { selectMove :: m Move }
-- or even
type Player m = m Move
What the second part means is to use classes like MonadIO and MonadState to keep your Player values polymorphic, and choose an appropriate monad instance only at the end after combining all the players. For example, you might have
computerPlayer :: MonadReader GameState m => Player m
randomPlayer :: MonadRandom m => Player m
humanPlayer :: (MonadIO m, MonadReader GameState m) => Player m
Perhaps you will find there are other players you want, too. Anyway, the point of this is that once you've created all these players, if they are typeclass polymorphic as above, you may choose a particular monad that implements all the required classes and you are done. For example, for these three, you might choose ReaderT GameState IO.
Good luck!

Related

Avoiding thunks in sparsely evaluated list generated by monadic unfold

I have a simulation library that uses the FFI wrapped in a monad M, carrying a context. All the foreign functions are pure, so I've decided to make the monad lazy, which is normally convenient for flow-control. I represent my simulation as a list of simulation-frames, that I can consume by either writing to a file, or by displaying the frame graphically.
simulation :: [(Frame -> M Frame)] -> Frame -> M [Frame]
simulation [] frame = return [frame]
simulation (step:steps) frame
= step frame >>= fmap (frame:) . simulation steps
Each frame consists of a tuple of newtype-wrapped ForeignPtrs that I can lift to my Haskell representation with
lift :: Frame -> M HFrame
Since the time-steps in my simulation are quite short, I only want to look at every n frames, for which I use
takeEvery n l = foldr cons nil l 0 where
nil _ = []
cons x rest 0 = x : rest n
cons x rest n = rest (n-1)
So my code looks something like
main = consume
$ takeEvery n
$ runM
$ simulation steps initialFrame >>= mapM lift
Now, the problem is that as I increase n, a thunk builds up. I've tried a couple of different ways to try to strictly evaluate each frame in simulation, but I have yet to figure out how to do so. ForeignPtr doesn't appear to have a NFData instance, so I can't use deepseq, but all my attempts with seq, including using seq on each element in the tuple, have been without noticeable effect.
EDIT:
Upon request, I have included more specifics, that I initially excluded since I think they are probably mostly noise for this question.
The monad
newtype FT c a = FT (Context -> a)
instance Functor (FT c) where
fmap f (FT a) = FT (f.a)
instance Applicative (FT c) where
pure a = FT (\_ -> a)
(<*>) (FT a) (FT b) = FT (\c -> a c $ b c)
instance Monad (FT c) where
return = pure
(>>=) (FT a) f = FT (\c -> (\(FT b) -> b c) $ f $ a c)
runFTIn :: Context -> (forall c. FT c a) -> a
runFTIn context (FT a) = a context
runFTWith :: [ContextOption] -> (forall c. FT c a) -> a
runFTWith options a
= unsafePerformIO
$ getContext options >>= \c -> return $ runFTIn c a
runFT = runFTWith []
unsafeLiftFromIO :: (Context -> IO a) -> FT c a
unsafeLiftFromIO a = FT (\c -> unsafePerformIO $ a c)
All the foreign functions are lifted from IO with unsafeLiftFromIO
newtype Box c = Box (ForeignPtr RawBox)
newtype Coordinates c = Coordinates (ForeignPtr RawCoordinates)
type Frame c = (Box c, Coordinates c)
liftBox :: Box c -> FT c HBox
liftCoordinates :: Coordinates c -> FT c HCoordinates
liftFrame (box, coordinates) = do
box' <- liftBox box
coordinates' <- liftCoordinates coordinates
return (box', coordinates')
The steps themselves are supposed to be arbitrary (Frame c -> FT c (Frame c)), so strictness should preferably be in the higher level code.
EDIT2:
I have now tried to use Streamly, however the problem persists, so I think the issue really is finding a way to strictly evaluate ForeignPtrs.
current implementations:
import Streamly
import qualified Streamly.Prelude as S
import qualified Streamly.Internal.Data.Stream.Serial as Serial
takeEvery n = Serial.unfoldrM ((fmap.fmap) (\(h, t) -> (h, S.drop (n-1) t)) . S.uncons)
(#) = flip ($)
simulation
:: (IsStream t)
=> Frame c
-> t (FT c) (Frame c -> FT c (Frame c))
-> t (FT c) (Frame c)
simulation frame = S.scanlM' (#) frame
EDIT3:
To clarify the symptoms and how I have diagnosed the problem.
The library calls OpenCL functions running on a GPU. I am sure that the freeing of the pointers is handled correctly - the ForeignPtrs have the correct freeing functions, and memory use is independent of total number of steps as long as this number is larger than n. What I find is that memory use on the GPU is basically linearly correlated to n. The consumer I've been using for this testing is
import qualified Data.ByteString.Lazy as BL
import Data.Binary
import Data.Binary.Put
writeTrajectory fn = fmap (BL.writeFile fn . runPut) . S.foldr ((>>).putFrame) (pure ()) . serially
For my streamly implementation, and
writeTrajectory fn = BL.writeFile fn . runPut . MapM_ putFrame
For the original implementation. Both should consume the stream continuously. I've generated the steps for testing with replicate.
I am unsure of how to more precisely analyze the memory-use on the GPU. System memory use is not an issue here.
Update:
I am starting to think it's not a matter of strictness, but of GC-problems. The run-time system does not know the size of the memory allocated on the GPU and so does not know to collect the pointers, this is less of an issue when there is stuff going on CPU-side as well, as that will produce allocations too, activating the GC. This would explain the slightly non-determinstic memory usage, but linear correlation to n that I've seen. How too solve this nicely is another issue, but I suspect there will be a substantial overhaul to my code.
I think the issue really is finding a way to strictly evaluate ForeignPtrs
If that is really the issue, one way to do that is to change the second clause of simulation:
{-# LANGUAGE BangPatterns #-}
simulation :: [(Frame -> M Frame)] -> Frame -> M [Frame]
simulation [] frame = return [frame]
simulation (step:steps) frame#(!_, !_) -- Evaluate both components of the pair
= step frame >>= fmap (frame:) . simulation steps

Re-dress a ST monad as something similar to the State monad

Here's the scenario: Given is a C library, with some struct at its core and operations thereon provided by an abundance of C functions.
Step 1: Using Haskell's FFI a wrapper is created. It has functions like myCLibInit :: IO MyCLibObj, myCLibOp1 :: MyCLibObj -> ... -> IO (), and so on. MyCLibObj is an opaque type that carries (and hides) a Ptr or ForeignPtr to the actual C struct, for example as shown in this wiki or in RWH ch. 17.
Step 2: Using unsafeIOToST from Control.Monad.ST.Unsafe convert all the IO actions into ST actions. This is done by introducing something like
data STMyCLib s = STMyCLib MyCLibObj
and then wrapping all IO functions in ST functions, for example:
myCLibInit' :: ST s (STMyCLib s)
myCLibInit' = unsafeIOToST $ STMyCLib <$> myCLibInit
This allows to write imperative-style programs that mirror the use of the OO-like C library, e.g.:
doSomething :: ST s Bool
doSomething = do
obj1 <- myCLibInit'
success1 <- myCLibOp1' obj1 "some-other-input"
...
obj2 <- myCLibInit'
result <- myCLibOp2' obj2 42
...
return True -- or False
main :: IO ()
main = do
...
let success = runST doSomething
...
Step 3: Often it doesn't make sense to mingle operations on several MyCLibObj in one do-block. For example when the C struct is (or should be thought of as) a singleton instance. Doing something like in doSomething above is either nonsensical, or just plain forbidden (for example, when the C struct is a static). In this case language resembling the one of the State monad is necessary:
doSomething :: ResultType
doSomething = withMyCLibInstance $ do
success <- myCLibOp1'' "some-other-input"
result <- myCLibOp2'' 42
...
return result
where
withMyCLibInstance :: Q a -> a
And this leads to the question: How can the ST s a monad be re-dressed as something that resembles more the State monad. Since withMyCLibInstance would use the runST function the new monad, let's call it Q (for 'q'uestion), should be
newtype Q a = Q (forall s. ST s a)
This looks thoroughly weird to me. I'm already struggling with implementing the Functor instance for this Q, let alone Applicative and Monad. ST s actually is a monad, already, but state s mustn't escape the ST monad, hence the forall s. ST s a. It's the only way to get rid of the s because runST :: (forall s. ST s a) -> a, and withMyCLibInstance is just a myCLibInit' followed by a runST. But somehow this doesn't fit.
What is the right way to tackle step 3? Should I even do step 2, or roll my Q right after step 1? My sense is that this should be quite simple. The ST monad has all I need, the Q just needs to be set up the right way...
Update 1: The singleton and static struct examples in step 3 are not very good. If two such do blocks were executed in parallel, very bad things might happen, i.e. both do blocks would work on the same C struct in parallel.
You can use a reader effect to access a singleton, instantiating it only in the run function:
newtype MyCLibST s a = MyCLibST { unMyCLibST :: ReaderT (STMyCLib s) (ST s) a }
runMyCLibST :: (forall s. MyCLibST s a) -> a
runMyCLibST m = runST (myCLibInit >>= runReaderT (unMyCLibST m))
-- Wrap the API with this.
unsafeMkMyCLibST :: (MyCLibObj -> IO a) -> MyCLibST s a
s should appear as a parameter to MyCLibST if you want to keep access to other ST features like mutable references and arrays.

On Haskell, what is the linguistic way to represent a card effect for a card game?

I have a simple one-player Card Game:
data Player = Player {
_hand :: [Card],
_deck :: [Card],
_board :: [Card]}
$(makeLenses ''Player)
Some cards have an effect. For example, "Erk" is a card with the following effect:
Flip a coin. If heads, shuffle your deck.
I've implemented it as such:
shuffleDeck :: (MonadRandom m, Functor m) => Player -> m Player
shuffleDeck = deck shuffleM
randomCoin :: (MonadRandom m) => m Coin
randomCoin = getRandom
flipCoin :: (MonadRandom m) => m a -> m a -> m a
flipCoin head tail = randomCoin >>= branch where
branch Head = head
branch Tail = tail
-- Flip a coin. If heads, shuffle your deck.
erk :: (MonadRandom m, Functor m) => Player -> m Player
erk player = flipCoin (deck shuffleM player) (return player)
While this certainly does the job, I find an issue on the forced coupling to the Random library. What if I later on have a card that depends on another monad? Then I'd have to rewrite the definition of every card defined so far (so they have the same type). I'd prefer a way to describe the logic of my game entirely independent from the Random (and any other). Something like that:
erk :: CardAction
erk = do
coin <- flipCoin
case coin of
Head -> shuffleDeck
Tail -> doNothing
I could, later on, have a runGame function that does the connection.
runGame :: (RandomGen g) => g -> CardAction -> Player -> Player
I'm not sure that would help. What is the correct, linguistic way to deal with this pattern?
This is one of the engineering problems the mtl library was designed to solve. It looks like you're already using it, but don't realize its full potential.
The idea is to make monad transformer stacks easier to work with using typeclasses. A problem with normal monad transformer stacks is that you have to know all of the transformers you're using when you write a function, and changing the stack of transformers changes how lifts work. mtl solves this by defining a typeclass for each transformer it has. This lets you write functions that have a class constraint for each transformer it requires but can work on any stack of transformers that includes at least those.
This means that you can freely write functions with different sets of constraints and then use them with your game monad, as long as you game monad has at least those capabilities.
For example, you could have
erk :: MonadRandom m => ...
incr :: MonadState GameState m => ...
err :: MonadError GameError m => ...
lots :: (MonadRandom m, MonadState GameState m) => ...
and define your Game a type to support all of those:
type Game a = forall g. RandT g (StateT GameState (ErrorT GameError IO)) a
You'd be able to use all of these interchangeably within Game, because Game belongs to all of those typeclasses. Moreover, you wouldn't have to change anything except the definition of Game if you wanted to add more capabilities.
There's one important limitation to keep in mind: you can only access one instance of each transformer. This means that you can only have one StateT and one ErrorT in your whole stack. This is why StateT uses a custom GameState type: you can just put all of the different things you may want to store throughout your game into that one type so that you only need one StateT. (GameError does the same for ErrorT.)
For code like this, you can get away with just using the Game type directly when you define your functions:
flipCoin :: Game a -> Game a -> Game a
flipCoin a b = ...
Since getRandom has a type polymorphic over m itself, it will work with whatever Game happens to be as long as it has at least a RandT (or something equivalent) inside.
So, to answer you question, you can just rely on the existing mtl typeclasses to take care of this. All of the primitive operations like getRandom are polymorphic over their monad, so they will work with whatever stack you end up with in the end. Just wrap all your transformers into a type of your own (Game), and you're all set.
This sounds like a good use-case for the operational package. It lets you define a monad as a set of operations and their return types using a GADT and you can then easily build an interpreter function like the runGame function you suggested. For example:
{-# LANGUAGE GADTs #-}
import Control.Monad.Operational
import System.Random
data Player = Player {
_hand :: [Card],
_deck :: [Card],
_board :: [Card]}
data Coin = Head | Tail
data CardOp a where
FlipCoin :: CardOp Coin
ShuffleDeck :: CardOp ()
type CardAction = Program CardOp
flipCoin :: CardAction Coin
flipCoin = singleton FlipCoin
shuffleDeck :: CardAction ()
shuffleDeck = singleton ShuffleDeck
erk :: CardAction ()
erk = do
coin <- flipCoin
case coin of
Head -> shuffleDeck
Tail -> return ()
runGame :: RandomGen g => g -> CardAction a -> Player -> Player
runGame = step where
step g action player = case view action of
Return _ -> player
FlipCoin :>>= continue ->
let (heads, g') = random g
coin = if heads then Head else Tail
in step g' (continue coin) player
...etc...
However, you might also want to consider just describing all your card actions as a simple ADT without do-syntax. I.e.
data CardAction
= CoinFlip CardAction CardAction
| ShuffleDeck
| DoNothing
erk :: CardAction
erk = CoinFlip ShuffleDeck DoNothing
You can easily write an interpreter for the ADT and as a bonus you can also e.g. generate the card's rule text automatically.

Composing Stateful functions in Haskell

What is the simplest Haskell library that allows composition of stateful functions?
We can use the State monad to compute a stock's exponentially-weighted moving average as follows:
import Control.Monad.State.Lazy
import Data.Functor.Identity
type StockPrice = Double
type EWMAState = Double
type EWMAResult = Double
computeEWMA :: Double -> StockPrice -> State EWMAState EWMAResult
computeEWMA α price = do oldEWMA <- get
let newEWMA = α * oldEWMA + (1.0 - α) * price
put newEWMA
return newEWMA
However, it's complicated to write a function that calls other stateful functions.
For example, to find all data points where the stock's short-term average crosses its long-term average, we could write:
computeShortTermEWMA = computeEWMA 0.2
computeLongTermEWMA = computeEWMA 0.8
type CrossingState = Bool
type GoldenCrossState = (CrossingState, EWMAState, EWMAState)
checkIfGoldenCross :: StockPrice -> State GoldenCrossState String
checkIfGoldenCross price = do (oldCrossingState, oldShortState, oldLongState) <- get
let (shortEWMA, newShortState) = runState (computeShortTermEWMA price) oldShortState
let (longEWMA, newLongState) = runState (computeLongTermEWMA price) oldLongState
let newCrossingState = (shortEWMA < longEWMA)
put (newCrossingState, newShortState, newLongState)
return (if newCrossingState == oldCrossingState then
"no cross"
else
"golden cross!")
Since checkIfGoldenCross calls computeShortTermEWMA and computeLongTermEWMA, we must manually wrap/unwrap their states.
Is there a more elegant way?
If I understood your code correctly, you don't share state between the call to computeShortTermEWMA and computeLongTermEWMA. They're just two entirely independent functions which happen to use state internally themselves. In this case, the elegant thing to do would be to encapsulate runState in the definitions of computeShortTermEWMA and computeLongTermEWMA, since they're separate self-contained entities:
computeShortTermEWMA start price = runState (computeEWMA 0.2 price) start
All this does is make the call site a bit neater though; I just moved the runState into the definition. This marks the state a local implementation detail of computing the EWMA, which is what it really is. This is underscored by the way GoldenCrossState is a different type from EWMAState.
In other words, you're not really composing stateful functions; rather, you're composing functions that happen to use state inside. You can just hide that detail.
More generally, I don't really see what you're using the state for at all. I suppose you would use it to iterate through the stock price, maintaining the EWMA. However, I don't think this is necessarily the best way to do it. Instead, I would consider writing your EWMA function over a list of stock prices, using something like a scan. This should make your other analysis functions easier to implement, since they'll just be list functions as well. (In the future, if you need to deal with IO, you can always switch over to something like Pipes which presents an interface really similar to lists.)
There is really no need to use any monad at all for these simple functions. You're (ab)using the State monad to calculate a one-off result in computeEWMA when there is no state involved. The only line that is actually important is the formula for EWMA, so let's pull that into it's own function.
ewma :: Double -> Double -> Double -> Double
ewma a price t = a * t + (1 - a) * price
If you inline the definition of State and ignore the String values, this next function has almost the exact same signature as your original checkIfGoldenCross!
type EWMAState = (Bool, Double, Double)
ewmaStep :: Double -> EWMAState -> EWMAState
ewmaStep price (crossing, short, long) =
(crossing == newCrossing, newShort, newLong)
where newCrossing = newShort < newLong
newShort = ewma 0.2 price short
newLong = ewma 0.8 price long
Although it doesn't use the State monad, we're certainly dealing with state here. ewmaStep takes a stock price, the old EWMAState and returns a new EWMAState.
Now putting it all together with scanr :: (a -> b -> b) -> b -> [a] -> [b]
-- a list of stock prices
prices = [1.2, 3.7, 2.8, 4.3]
_1 (a, _, _) = a
main = print . map _1 $ scanr ewmaStep (False, 0, 0) prices
-- [False, True, False, True, False]
Because fold* and scan* use the cumulative result of previous values to compute each successive one, they are "stateful" enough that they can often be used in cases like this.
In this particular case, you have a y -> (a, y) and a z -> (b, z) that you want to use to compose a (x, y, z) -> (c, (x, y, z)). Having never used lens before, this seems like a perfect opportunity.
In general, we can promote a stateful operations on a sub-state to operate on the whole state like this:
promote :: Lens' s s' -> StateT s' m a -> StateT s m a
promote lens act = do
big <- get
let little = view lens big
(res, little') = runState act little
big' = set lens little' big
put big'
return res
-- Feel free to golf and optimize, but this is pretty readable.
Our lens a witness that s' is a sub-state of s.
I don't know if "promote" is a good name, and I don't recall seeing this function defined elsewhere (but it's probably already in lens).
The witnesses you need are named _2 and _3 in lens so, you could change a couple of lines of code to look like:
shortEWMA <- promote _2 (computeShortTermEWMA price)
longEWMA <- promote _3 (computeLongTermEWMA price)
If a Lens allows you to focus on inner values, maybe this combinator should be called blurredBy (for prefix application) or obscures (for infix application).
With a little type class magic, monad transformers allow you to have nested transformers of the same type. First, you will need a new instance for MonadState:
{-# LANGUAGE
UndecidableInstances
, OverlappingInstances
#-}
instance (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (t m) where
state f = lift (state f)
Then you must define your EWMAState as a newtype, tagged with the type of term (alternatively, it could be two different types - but using a phantom type as a tag has its advantages):
data Term = ShortTerm | LongTerm
type StockPrice = Double
newtype EWMAState (t :: Term) = EWMAState Double
type EWMAResult = Double
type CrossingState = Bool
Now, computeEWMA works on an EWMASTate which is polymorphic in term (the afformentioned example of tagging with phantom types), and in monad:
computeEWMA :: (MonadState (EWMAState t) m) => Double -> StockPrice -> m EWMAResult
computeEWMA a price = do
EWMAState old <- get
let new = a * old + (1.0 - a) * price
put $ EWMAState new
return new
For specific instances, you give them monomorphic type signatures:
computeShortTermEWMA :: (MonadState (EWMAState ShortTerm) m) => StockPrice -> m EWMAResult
computeShortTermEWMA = computeEWMA 0.2
computeLongTermEWMA :: (MonadState (EWMAState LongTerm) m) => StockPrice -> m EWMAResult
computeLongTermEWMA = computeEWMA 0.8
Finally, your function:
checkIfGoldenCross ::
( MonadState (EWMAState ShortTerm) m
, MonadState (EWMAState LongTerm) m
, MonadState CrossingState m) =>
StockPrice -> m String
checkIfGoldenCross price = do
oldCrossingState <- get
shortEWMA <- computeShortTermEWMA price
longEWMA <- computeLongTermEWMA price
let newCrossingState = shortEWMA < longEWMA
put newCrossingState
return (if newCrossingState == oldCrossingState then "no cross" else "golden cross!")
The only downside is you have to explicitly give a type signature - in fact, the instance we introduced at the beginning has ruined all hopes of good type errors and type inference for cases where you have multiple copies of the same transformer in a stack.
Then a small helper function:
runState3 :: StateT a (StateT b (State c)) x -> a -> b -> c -> ((a , b , c) , x)
runState3 sa a b c = ((a' , b', c'), x) where
(((x, a'), b'), c') = runState (runStateT (runStateT sa a) b) c
and:
>runState3 (checkIfGoldenCross 123) (shortTerm 123) (longTerm 123) True
((EWMAState 123.0,EWMAState 123.0,False),"golden cross!")
>runState3 (checkIfGoldenCross 123) (shortTerm 456) (longTerm 789) True
((EWMAState 189.60000000000002,EWMAState 655.8000000000001,True),"no cross")

Combining multiple states in StateT

I am writing a program that runs as a daemon.
To create the daemon, the user supplies a set of
implementations for each of the required classes (one of them is a database)
All of these classes have functions have
type signatures of the form StateT s IO a,
but s is different for each class.
Suppose each of the classes follows this pattern:
import Control.Monad (liftM)
import Control.Monad.State (StateT(..), get)
class Hammer h where
driveNail :: StateT h IO ()
data ClawHammer = MkClawHammer Int -- the real implementation is more complex
instance Hammer ClawHammer where
driveNail = return () -- the real implementation is more complex
-- Plus additional classes for wrenches, screwdrivers, etc.
Now I can define a record that represents the implementation chosen by
the user for each "slot".
data MultiTool h = MultiTool {
hammer :: h
-- Plus additional fields for wrenches, screwdrivers, etc.
}
And the daemon does most of its work in the StateT (MultiTool h ...) IO ()
monad.
Now, since the multitool contains a hammer, I can use it in any situation
where a hammer is needed. In other words, the MultiTool type
can implement any of the classes it contains, if I write code like this:
stateMap :: Monad m => (s -> t) -> (t -> s) -> StateT s m a -> StateT t m a
stateMap f g (StateT h) = StateT $ liftM (fmap f) . h . g
withHammer :: StateT h IO () -> StateT (MultiTool h) IO ()
withHammer runProgram = do
t <- get
stateMap (\h -> t {hammer=h}) hammer runProgram
instance Hammer h => Hammer (MultiTool h) where
driveNail = withHammer driveNail
But the implementations of withHammer, withWrench, withScrewdriver, etc.
are basically identical. It would be nice to be able to write something
like this...
--withMember accessor runProgram = do
-- u <- get
-- stateMap (\h -> u {accessor=h}) accessor runProgram
-- instance Hammer h => Hammer (MultiTool h) where
-- driveNail = withMember hammer driveNail
But of course that won't compile.
I suspect my solution is too object-oriented.
Is there a better way?
Monad transformers, maybe?
Thank you in advance for any suggestions.
If you want to go with a large global state like in your case, then what you want to use is lenses, as suggested by Ben. I too recommend Edward Kmett's lens library. However, there is another, perhaps nicer way.
Servers have the property that the program runs continuously and performs the same operation over a state space. The trouble starts when you want to modularize your server, in which case you want more than just some global state. You want modules to have their own state.
Let's think of a module as something that transforms a Request to a Response:
Module :: (Request -> m Response) -> Module m
Now if it has some state, then this state becomes noticable in that the module might give a different answer the next time. There are a number of ways to do this, for example the following:
Module :: s -> ((Request, s) -> m (Response s)) -> Module m
But a much nicer and equivalent way to express this is the following constructor (we will build a type around it soon):
Module :: (Request -> m (Response, Module m)) -> Module m
This module maps a request to a response, but along the way also returns a new version of itself. Let's go further and make requests and responses polymorphic:
Module :: (a -> m (b, Module m a b)) -> Module m a b
Now if the output type of a module matches another module's input type, then you can compose them like regular functions. This composition is associative and has a polymorphic identity. This sounds a lot like a category, and in fact it is! It is a category, an applicative functor and an arrow.
newtype Module m a b =
Module (a -> m (b, Module m a b))
instance (Monad m) => Applicative (Module m a)
instance (Monad m) => Arrow (Module m)
instance (Monad m) => Category (Module m)
instance (Monad m) => Functor (Module m a)
We can now compose two modules that have their own individual local state without even knowing about it! But that's not sufficient. We want more. How about modules that can be switched among? Let's extend our little module system such that modules can actually choose not to give an answer:
newtype Module m a b =
Module (a -> m (Maybe b, Module m a b))
This allows another form of composition that is orthogonal to (.): Now our type is also a family of Alternative functors:
instance (Monad m) => Alternative (Module m a)
Now a module can choose whether to respond to a request, and if not, the next module will be tried. Simple. You have just reinvented the wire category. =)
Of course you don't need to reinvent this. The Netwire library implements this design pattern and comes with a large library of predefined "modules" (called wires). See the Control.Wire module for a tutorial.
Here's a concrete example of how to use lens like everybody else is talking about. In the following code example, Type1 is the local state (i.e. your hammer), and Type2 is the global state (i.e. your multitool). lens provides the zoom function which lets you run a localized state computation that zooms in on any field defined by a lens:
import Control.Lens
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
data Type1 = Type1 {
_field1 :: Int ,
_field2 :: Double}
field1 :: SimpleLens Type1 Int
field1 = lens _field1 (\x a -> x { _field1 = a})
field2 :: SimpleLens Type1 Double
field2 = lens _field2 (\x a -> x { _field2 = a})
data Type2 = Type2 {
_type1 :: Type1 ,
_field3 :: String}
type1 :: SimpleLens Type2 Type1
type1 = lens _type1 (\x a -> x { _type1 = a})
field3 :: SimpleLens Type2 String
field3 = lens _field3 (\x a -> x { _field3 = a})
localCode :: StateT Type1 IO ()
localCode = do
field1 += 3
field2 .= 5.0
lift $ putStrLn "Done!"
globalCode :: StateT Type2 IO ()
globalCode = do
f1 <- zoom type1 $ do
localCode
use field1
field3 %= (++ show f1)
f3 <- use field3
lift $ putStrLn f3
main = runStateT globalCode (Type2 (Type1 9 4.0) "Hello: ")
zoom is not limited to immediate sub-fields of a type. Since lenses are composable, you can zoom as deep as you want in a single operation just by doing something like:
zoom (field1a . field2c . field3b . field4j) $ do ...
This sounds very much like an application of lenses.
Lenses are a specification of a sub-field of some data. The idea is you have some value toolLens and functions view and set so that view toolLens :: MultiTool h -> h fetches the tool and set toolLens :: MultiTool h -> h -> MultiTool h replaces it with a new value. Then you can easily define your withMember as a function just accepting a lens.
Lens technology has advanced a great deal recently, and they are now incredibly capable. The most powerful library around at the time of writing is Edward Kmett's lens library, which is a bit much to swallow, but pretty simple once you find the features you want. You can also search for more questions about lenses here on SO, e.g. Functional lenses which links to lenses, fclabels, data-accessor - which library for structure access and mutation is better, or the lenses tag.
I created a lensed extensible record library called data-diverse-lens which allows combining multiple ReaderT (or StateT) like this gist:
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import Control.Lens
import Control.Monad.Reader
import Control.Monad.State
import Data.Diverse.Lens
import Data.Semigroup
foo :: (MonadReader r m, HasItem' Int r, HasItem' String r) => m (Int, String)
foo = do
i <- view (item' #Int) -- explicitly specify type
s <- view item' -- type can also be inferred
pure (i + 10, s <> "bar")
bar :: (MonadState s m, HasItem' Int s, HasItem' String s) => m ()
bar = do
(item' #Int) %= (+10) -- explicitly specify type
item' %= (<> "bar") -- type can also be inferred
pure ()
main :: IO ()
main = do
-- example of running ReaderT with multiple items
(i, s) <- runReaderT foo ((2 :: Int) ./ "foo" ./ nil)
putStrLn $ show i <> s -- prints out "12foobar"
-- example of running StateT with multiple items
is <- execStateT bar ((2 :: Int) ./ "foo" ./ nil)
putStrLn $ show (view (item #Int) is) <> (view (item #String) is) -- prints out "12foobar"
Data.Has is a simpler library that does the same with tuples. Example from the library front page:
{-# LANGUAGE FlexibleContexts #-}
-- in some library code
...
logInAnyReaderHasLogger :: (Has Logger r, MonadReader r m) => LogString -> m ()
logInAnyReaderHasLogger s = asks getter >>= logWithLogger s
queryInAnyReaderHasSQL :: (Has SqlBackEnd r, MonadReader r m) => Query -> m a
queryInAnyReaderHasSQL q = asks getter >>= queryWithSQL q
...
-- now you want to use these effects together
...
logger <- initLogger ...
sql <- initSqlBackEnd ...
(`runReader` (logger, sql)) $ do
...
logInAnyReaderHasLogger ...
...
x <- queryInAnyReaderHasSQL ...
...

Resources