[Haskell-cafe] MonadPrompt + Gtk2Hs = ?

[Felipe Lessa]

(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.