<font face="courier new,monospace">(This message is a literate haskell file.&nbsp;&nbsp;Code for the &quot;Prompt&quot; monad is<br>preceded by &quot;&gt;&quot;; code for my examples is preceded by &quot;]&quot; and isn&#39;t complete,
<br>but intended for illustration.)<br><br>I&#39;ve been trying to implement a few rules-driven board/card games in Haskell<br>and I always run into the ugly problem of &quot;how do I get user input&quot;?<br><br>The usual technique is to embed the game in the IO Monad:
<br><br>] type Game = IO<br>] -- or<br>] type Game = StateT GameState IO<br><br>The problem with this approach is that now arbitrary IO computations are<br>expressible as part of a game action, which makes it much harder to implement
<br>things like replay, undo, and especially testing!<br><br>The goal was to be able to write code like this:<br><br>] takeTurn :: Player -&gt; Game ()<br>] takeTurn player = do<br>]&nbsp;&nbsp;&nbsp;&nbsp; piece&nbsp;&nbsp;&lt;- action (ChoosePiece player)
<br>]&nbsp;&nbsp;&nbsp;&nbsp; attack &lt;- action (ChooseAttack player piece)<br>]&nbsp;&nbsp;&nbsp;&nbsp; bonusTurn &lt;- executeAttack piece attack<br>]&nbsp;&nbsp;&nbsp;&nbsp; when bonusTurn $ takeTurn player<br><br>but be able to script the code for testing, allow undo, automatically
<br>be able to save replays, etc.<br><br>While thinking about this problem earlier this week, I came up with the<br>following solution:<br><br>&gt; {-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances&nbsp;&nbsp;#-}<br>&gt; -- undecidable instances is only needed for the MonadTrans instance below
<br>&gt;<br>&gt; module Prompt where<br>&gt; import Control.Monad.Trans<br>&gt; import Control.Monad.Identity<br><br>&gt; class Monad m =&gt; MonadPrompt p m | m -&gt; p where<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;prompt :: p a -&gt; m a<br><br>&quot;prompt&quot; is an action that takes a prompt type and gives you a result.
<br><br>A simple example:<br>] prompt [1,3,5] :: MonadPrompt [] m =&gt; m Int<br><br>This prompt would ask for someone to pick a value from the list and return it.<br>This would be somewhat useful on its own; you could implement a &quot;choose&quot;
<br>function that picked randomly from a list of options and gave<br>non-deterministic (or even exhaustive) testing, but on its own this wouldn&#39;t<br>be much better than the list monad.<br><br>What really made this click for me was that the prompt type could be built
<br>on a GADT:<br><br>] newtype GamePrompt a = GP (GameState, GameChoice a)<br>] data GameChoice a where<br>]&nbsp;&nbsp;&nbsp;&nbsp;-- pick a piece to act with<br>]&nbsp;&nbsp;&nbsp;&nbsp;ChoosePiece :: Player -&gt; GameChoice GamePiece<br>]&nbsp;&nbsp;&nbsp;&nbsp;-- pick how they should attack
<br>]&nbsp;&nbsp;&nbsp;&nbsp;ChooseAttack :: Player -&gt; GamePiece -&gt; GameChoice AttackType<br>]&nbsp;&nbsp;&nbsp;&nbsp;-- etc.<br><br>Now you can use this type information as part of a &quot;handler&quot; function:<br>] gameIO :: GamePrompt a -&gt; IO a<br>
] gameIO (GP (state, ChoosePiece player)) = getPiece state player<br>] gameIO (GP (state, ChooseAttack player piece)) = attackMenu player piece<br>] -- ...<br><br>The neat thing here is that the GADT specializes the type of &quot;IO a&quot; on the
<br>right hand side.&nbsp;&nbsp;So, &quot;getPiece state player&quot; has the type &quot;IO GamePiece&quot;, not<br>the general &quot;IO a&quot;.&nbsp;&nbsp;So the GADT is serving as a witness of the type of<br>response wanted by the game.<br>
<br>Another neat things is that, you don&#39;t need to embed this in the IO monad at<br>all; you could instead run a pure computation to do AI, or even use it for<br>unit testing!<br><br>&gt; -- unit testing example<br>&gt; data ScriptElem p where SE :: p a -&gt; a -&gt; ScriptElem p
<br>&gt; type Script p = [ScriptElem p]<br>&gt;<br>&gt; infix 1 --&gt;<br>&gt; (--&gt;) = SE<br><br><br>] gameScript :: ScriptElem GameChoice -&gt; GameChoice a -&gt; Maybe a<br>] gameScript (SE (ChoosePiece _)&nbsp;&nbsp;&nbsp;&nbsp;piece)&nbsp;&nbsp;(ChoosePiece _)&nbsp;&nbsp;&nbsp;&nbsp;= Just piece
<br>] gameScript (SE (ChooseAttack _ _) attack) (ChooseAttack _ _) = Just attack<br>] gameScript _&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;_&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;= Nothing<br>]<br>] testGame :: Script GameChoice<br>] testGame =<br>]&nbsp;&nbsp; [ ChoosePiece&nbsp;&nbsp;P1&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;--&gt; Knight
<br>]&nbsp;&nbsp; , ChooseAttack P1 Knight --&gt; Charge<br>]&nbsp;&nbsp; , ChoosePiece&nbsp;&nbsp;P2&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;--&gt; FootSoldier<br>]&nbsp;&nbsp; , ...<br>]&nbsp;&nbsp; ]<br><br>So, how to implement all of this?<br><br>&gt; data Prompt (p :: * -&gt; *) :: (* -&gt; *) where
<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp; PromptDone :: result -&gt; Prompt p result<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp; -- a is the type needed to continue the computation<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp; Prompt :: p a -&gt; (a -&gt; Prompt p result) -&gt; Prompt p result<br><br>This doesn&#39;t require GADT&#39;s; it&#39;s just using existential types, but I like
<br>the aesthetics better this way.<br><br>Intuitively, a (Prompt p result) either gives you an immediate result<br>(PromptDone), or gives you a prompt which you need to reply to in order to<br>continue the computation.<br>
<br>This type is a MonadPrompt:<br><br>&gt; instance Functor (Prompt p) where<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;fmap f (PromptDone r) = PromptDone (f r)<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;fmap f (Prompt p cont) = Prompt p (fmap f . cont)<br>&gt;<br>&gt; instance Monad (Prompt p) where
<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;return = PromptDone<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;PromptDone r&nbsp;&nbsp;&gt;&gt;= f = f r<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;Prompt p cont &gt;&gt;= f = Prompt p ((&gt;&gt;= f) . cont)<br>&gt;<br>&gt; instance MonadPrompt p (Prompt p) where<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;prompt p = Prompt p return
<br>&gt;<br>&gt; -- Just for fun, make it work with StateT as well<br>&gt; -- (needs -fallow-undecidable-instances)<br>&gt; instance (Monad (t m), MonadTrans t, MonadPrompt p m) =&gt; MonadPrompt p (t m) where<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;prompt = lift . prompt
<br><br>The last bit to tie it together is an observation function which allows you to<br>run the game:<br><br>&gt; runPromptM :: Monad m =&gt; (forall a. p a -&gt; m a) -&gt; Prompt p r -&gt; m r<br>&gt; runPromptM _ (PromptDone r) = return r
<br>&gt; runPromptM f (Prompt pa c)&nbsp;&nbsp;= f pa &gt;&gt;= runPromptM f . c<br>&gt;<br>&gt; runPrompt :: (forall a. p a -&gt; a) -&gt; Prompt p r -&gt; r<br>&gt; runPrompt f p = runIdentity $ runPromptM (Identity . f) p<br>&gt;
<br>&gt; runScript :: (forall a. ScriptElem p -&gt; p a -&gt; Maybe a)<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; -&gt; Script p -&gt; Prompt p r -&gt; Maybe r<br>&gt; runScript _ []&nbsp;&nbsp;&nbsp;&nbsp; (PromptDone r) = Just r<br>&gt; runScript s (x:xs) (Prompt pa c)&nbsp;&nbsp;= case s x pa of
<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;Nothing -&gt; Nothing<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;Just a&nbsp;&nbsp;-&gt; runScript s xs (c a)<br>&gt; runScript _ _&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;_&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;= Nothing<br>&gt;&nbsp;&nbsp;&nbsp;&nbsp;-- script &amp; computation out of sync<br><br>My original goal is now achievable:
<br><br>] type Game = StateT GameState (Prompt GamePrompt)<br>]<br>] action :: GameChoice a -&gt; Game a<br>] action p = do<br>]&nbsp;&nbsp;&nbsp;&nbsp;state &lt;- get<br>]&nbsp;&nbsp;&nbsp;&nbsp;prompt $ GP (state, p)<br><br>] runGameScript :: Script GameChoice -&gt; GameState -&gt; Game a -&gt; Maybe (GameState, a)
<br>] runGameScript script initialState game<br>]&nbsp;&nbsp;&nbsp;&nbsp;= runScript scriptFn script&#39; (runStateT game initialState)<br>]&nbsp;&nbsp;&nbsp;&nbsp;where<br>]&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; script&#39; = map sEmbed script<br>]&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; scriptFn s (GP (s,p)) = gameScript (sExtract s) p
<br>]&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; sEmbed&nbsp;&nbsp; (SE p a) = SE (GP (undefined, p)) a<br>]&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; sExtract (SE (GP (_,p)) a) = SE p a<br><br>Any comments are welcome!&nbsp;&nbsp;Thanks for reading this far.<br><br>&nbsp;&nbsp;-- ryan<br><br></font>