(This e-mail is a literate Haskell file.) Ryan Ingram enlightened us with MonadPrompt as a very nice abstraction for turn-based games, allowing easy programming and testing. http://www.mail-archive.com/haskell-cafe@haskell.org/msg33040.html http://ryani.freeshell.org/haskell/ I wonder how nicely it fits on a Gtk2Hs application. =)
{-# OPTIONS_GHC -fglasgow-exts -Wall #-} import Control.Concurrent import Control.Concurrent.MVar import Control.Monad import Control.Monad.Fix import Graphics.UI.Gtk import System.IO import System.Random
Needed for the GADTs and some type signatures. (yes, I'm stuck with GHC 6.6.1 for now =/ ) While you read the e-mail, choose the appropriate main function
main :: IO () main = consoleMain -- main = gtkApp forkAttempt -- main = gtkApp subLoopAttempt -- main = gtkApp lastAttempt
For the purposes of this e-mail, I'll present here a simplified version of his MonadPrompt:
class Monad m => MonadPrompt p m | m -> p where prompt :: p a -> m a
data Prompt (p :: * -> *) r where PromptDone :: r -> Prompt p r Prompt :: p a -> (a -> Prompt p r) -> Prompt p r
instance Monad (Prompt p) where return = PromptDone PromptDone x >>= f = f x Prompt p cont >>= f = Prompt p ((>>= f) . cont)
instance MonadPrompt p (Prompt p) where prompt p = Prompt p return
With the monad above, we may program a simple guessing game. This is based on http://ryani.freeshell.org/haskell/Main.lhs and you can do every analysis done here with his sources, but I'm again trying to keep everything as simple as possible.
guessGame :: MonadPrompt GuessP m => Int -> m Int guessGame answer = guessMe 1 where guessMe tries = do prompt (Print $ "Guess #" ++ show tries ++ ":") guess <- prompt Guess if guess == answer then do prompt (Print "Right!") return tries else do prompt (Print $ "You guessed too " ++ if guess < answer then "low" else "high" ++ "! Try again.") guessMe (tries + 1)
Okay, so our game do prompts over the GuessP data type,
data GuessP a where
where you may ask the user for a guess
Guess :: GuessP Int
or you may show him some info about the game.
Print :: String -> GuessP ()
To play our little game, we have to execute the Prompt. We have
runPromptM :: Monad m => (forall a. p a -> m a) -> Prompt p r -> m r runPromptM _ (PromptDone result) = return result runPromptM f (Prompt p cont) = f p >>= runPromptM f . cont
which basically maps prompts to actions on some monad -- in particular, IO. Doing a console interface isn't hard at all:
consolePrompt :: forall a. GuessP a -> IO a consolePrompt (Print s) = putStrLn s consolePrompt Guess = fmap read getLine
guessGameNew :: MonadPrompt GuessP m => IO (m Int) guessGameNew = randomRIO (1, 10) >>= return . guessGame
consoleMain :: IO () consoleMain = do hSetBuffering stdout NoBuffering game <- guessGameNew attempts <- runPromptM consolePrompt game putStrLn $ "You took " ++ show attempts ++ " attempts."
That's really cool =). However, mapping runPromptM into a Gtk2Hs application isn't easy at all (we'll see why shortly). Before that, let's take the common blocks of code away. All of our attempts will develop a function that takes a function for showing info, an entry for reading guesses and a button that will be clicked to make the guess.
type AttemptCode = (String -> IO ()) -> Entry -> Button -> IO ()
gtkApp :: AttemptCode -> IO () gtkApp run = do unsafeInitGUIForThreadedRTS -- allows runghc w <- windowNew w `onDestroy` mainQuit container <- vBoxNew False 7 w `containerAdd` container
let showInfo info = do m <- messageDialogNew (Just w) [] MessageInfo ButtonsOk info dialogRun m >> widgetDestroy m
entry <- entryNew boxPackStart container entry PackNatural 0
button <- buttonNewWithLabel "Guess" boxPackStart container button PackNatural 0
widgetShowAll w timeoutAdd (run showInfo entry button >> return False) 0 mainGUI
With everything in place, let's start! The first naïve attempt would be to just connect every point
{- naïveAttempt :: AttemptCode naïveAttempt showInfo entry button = do game <- guessGameNew let mapping (Print s) = showInfo s mapping Guess = -- Oops -}
It's easy to see that we can't get the guess from our user using a function like 'getLine'. The problem lies in the fact that Gtk is event-driven, so every time we ask the user for something, we have to wait for the corresponding event that will bring us his answer. 'runPromptM' basically creates one big monolithic monad that will run from the beginning to the end of the game -- exactly the same thing 'mainGUI' does! The standard way of solving the problem of running two sequential things at once is using threads, and this solution is specially appealing since Control.Concurrent simplifies the matters *a lot*. So let's try this instead
forkAttempt :: AttemptCode forkAttempt showInfo entry button = do game <- guessGameNew forkIO $ do attempts <- runPromptM forkedMapping game postGUIAsync (showInfo $ "You took " ++ show attempts ++ " attempts.") return () where forkedMapping :: forall a. GuessP a -> IO a forkedMapping (Print s) = postGUIAsync (showInfo s) forkedMapping Guess = do v <- newEmptyMVar cid <- postGUISync $ onClicked button $ entryGetText entry >>= putMVar v guess <- takeMVar v -- f1 postGUISync (signalDisconnect cid) -- f2 return (read guess)
Problem solved? Not really: - This kind of implementation hides lots of subtle bugs. For example, because of postGUIAsync being used in Print case, the user will see multiple dialog boxes at once and -- strangely enough -- he'll see first the last message printed. It isn't always easy to see this kind of bug at first sight, and it can be very hard to track it down. - Another problem may happen with scheduling. For some reason, there are times in which it takes some time for the control to pass from the Gtk thread to the forkIO one, effectively 'freezing' the game for some time. Unfortunately this problem doesn't show up above, but I have experienced it on a larger game I'm currently programming using Prompt. - It is possible that the user clicks on the button between f1 and f2. Again, on this very simple example nothing seems to go wrong, but there shouldn't be anything between f1 and f2 as the GUI is on an inconsistent state. It should be noted that the scheduling problem can be mitigated using 'yield' on some key spots. This not only feels hackish, but also doesn't scale very well. Another approach that is sometimes adopted to solve this kind of problem is creating a main "sub-loop" with 'mainIteration'. This essentially removes the need for those nasty evil threads =).
subLoopAttempt :: AttemptCode subLoopAttempt showInfo entry button = do game <- guessGameNew attempts <- runPromptM subLoopMapping game showInfo $ "You took " ++ show attempts ++ " attempts." where subLoopMapping :: forall a. GuessP a -> IO a subLoopMapping (Print s) = showInfo s subLoopMapping Guess = do v <- newEmptyMVar cid <- onClicked button $ entryGetText entry >>= putMVar v guess <- subLoopGetMVar v signalDisconnect cid return (read guess)
Here comes the magic!
subLoopGetMVar :: MVar a -> IO a subLoopGetMVar v = do m <- tryTakeMVar v case m of Just r -> return r Nothing -> do quitting <- mainIteration when quitting (fail "quitting") subLoopGetMVar v
There are a couple of pitfalls in this approach as well: - The quitting code doesn't work very well anymore. Try to close the window before guessing right and you'll see an "user error" on the console. Some 'bracket' magic is needed to get out of the subloop without throwing errors at the user's face. - Every time we get into a subloop we add an overhead for every event the application receives. I don't know if this is important at all, maybe with lots of nested subloop. - The real problem is: what if the MVar gets full but does not generate an event? While 'subLoopGetMVar' waits for 'mainIteration', the game code should be executing already for a long time! Unfortunately I couldn't come up with a simple example that exposes the last problem listed above. But, for example, some network code could fill that MVar in a multiplayer internet game. In this case the game wouldn't proceed until an event was generated. It's known that to partially solve this problem it is possible to create a signal generator that runs every X milliseconds, giving an upper bound to the amount of time between putMVar being called and subLoopGetMVar finishing. This feels hackish and fragile as well, specially because it is difficult to hunt down bugs. But Prompt has a very *very* nice property we're missing to take advantage of here: it's is *pure*. In fact, I think that is one of the reasons why Ryan bothered sending us an e-mail -- you can not only plug different interfaces codes, but also plug no interface at all to make tests, with purity making matters very simple. Ryan also notes that "If you wanted to add undo, all you have to do is save off the current Prompt in the middle of runPromptM; you can return to the old state at any time." Eventually this feature rang some bells: you can save not only when you want to undo, but also when you want to ask something to the user. Unfortunately, I still haven't come up with a nice higher order function that generalizes this work without reinventing Prompt on an isomorphic type. Enough said, let's see how:
lastAttempt :: AttemptCode lastAttempt showInfo entry button = do game <- guessGameNew runPromptM' game where -- Signature required runPromptM' :: Prompt GuessP Int -> IO () -- note: not (IO Int)! runPromptM' (Prompt (Print s) c) = showInfo s >> runPromptM' (c ()) runPromptM' (Prompt Guess c) = do mfix $ \cid -> do let cont guess = do {signalDisconnect cid; runPromptM' (c $ read guess)} onClicked button $ entryGetText entry >>= cont return () runPromptM' (PromptDone attempts) = do showInfo $ "You took " ++ show attempts ++ " attempts."
After so many attempts looking with some much similar code, it may be hard to see exactly how our last attempt work. No threads, no MVars, no nothing. So I took out features, and now everything is better? =) Basically, we first assume that every time 'runPromptM'' is called, we're on Gtk's thread (which is easy in this case since there are no threads at all). Next, we see if we need to *wait* for something. In the Print case, we just call 'showInfo', so the code is the same as expanding 'subLoopMapping (Print s)' inside 'runPromptM'. This means that the Gtk event that called 'runPromptM'' will continue to execute the the next call to 'runPromptM'' as well. This is very nice, since it introduces no delays to the user (imagine a non-blocking showInfo -- e.g. printing on a textview). The PromptDone case is also very similar to what has been done before. However, in the Guess case we connect a signal to the button and return! This is where things get very different from the other approaches. When using 'forkIO', the forked thread would run from the game start until its end. When using 'mainIteration', the event that called 'subLoopAttempt' (in our case, the timeout) would execute until the end of the game. Instead, 'lastAttempt' will run only until the first Guess. Okay, so how do we proceed from here? The continuation of the 'Prompt' constructor goes inside 'cont's closure. When the user clicks on the button, it disconnects the signal and calls 'runPromptM'' again. Everything happens sequentially as I'm saying because there aren't any other threads playing with our continuation, so this not only removes the need for MVars but also fixes the whole problem of "will this run in the middle of that?". Even if the user could click twice at the same time, the Gtk main loop would execute only one event callback "concurrently" and by the time the other event gets its chance to execute we'll have disconnected its signal handler already. It's true that *another* callback would be connected if the guess was not right, but that doesn't cause any inconsistencies at all. Note also that we could have, for example, two buttons sharing the same continuation if their callbacks disconnected both 'ConnectID's before going on. No freezes, no races, no exceptions, no overheads. No generic 'runPromptM' abstraction as well, but I think the price is worth paying, specially because the other approaches have nasty subtle bugs. And we continue to have the possibility of using 'runPromptM' in our tests, for example. -- Oh, well. This e-mail got longer than I initially imagined, thanks God I started typing it on emacs already =). I'm looking forward suggestions on improvements and critics about problems in this last approach. Unfortunately the game I'm developing is still in an early stage, but I promise to release it under the GPL sometime soon =). Also, I welcome any meaningful comparison between 'lastAttempt' and 'callCC'. Thanks for reading until here, -- Felipe.