Patch to ansi-terminal-game

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game.hs

@@ -22,8 +22,10 @@ module Terminal.Game ( -- * Running
                        FPS,
                        Event(..),
                        GEnv(..),
-                       Game(..),
+                       Game,
+                       GameT(..),
                        playGame,
+                       playGameT,
                        ATGException(..),
 
                        -- ** Helpers
@@ -33,6 +35,7 @@ module Terminal.Game ( -- * Running
                        errorPress,
                        blankPlaneFull,
                        centerFull,
+                       cleanAndExit,
 
                        -- * Game logic
                        -- | Some convenient function dealing with
@@ -119,6 +122,11 @@ module Terminal.Game ( -- * Running
                        setupGame,
                        narrateGame,
 
+                       -- * Transformers
+                       GameIO(..),
+                       Test(..),
+                       Narrate(..)
+
                        -- | A quick and dirty way to have /hot reload/
                        -- (autorestarting your game when source files change)
                        -- is illustrated in @example/MainHotReload.hs@.
@@ -133,6 +141,7 @@ import Terminal.Game.Animation
 import Terminal.Game.Draw
 import Terminal.Game.Layer.Imperative
 import Terminal.Game.Layer.Object as O
+import Terminal.Game.Layer.Object.IO ( cleanAndExit )
 import Terminal.Game.Plane
 import Terminal.Game.Random
 import Text.LineBreak

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Imperative.hs

@@ -5,6 +5,7 @@
 -------------------------------------------------------------------------------
 
 {-# Language ScopedTypeVariables #-}
+{-# Language RankNTypes #-}
 
 module Terminal.Game.Layer.Imperative where
 
@@ -14,23 +15,26 @@ import Terminal.Game.Layer.Object
 import qualified Control.Concurrent as CC
 import qualified Control.Exception as E
 import qualified Control.Monad as CM
+import qualified Control.Monad.Trans          as T
 import qualified Data.Bool as B
 import qualified Data.List as D
 import qualified System.IO as SI
 
 import Terminal.Game.Plane
 
+type Game s = GameT IO s
+
 -- | Game definition datatype, parametrised on your gamestate. The two most
 -- important elements are the function dealing with logic and the drawing
 -- one. Check @alone@ demo (@cabal run -f examples alone@) to see a simple
 -- game in action.
-data Game s =
+data GameT m s =
         Game { gTPS           :: TPS,
                     -- ^ Game speed in ticks per second. You do not
                     -- need high values, since the 2D canvas is coarse
                     -- (e.g. 13 TPS is enough for action games).
                gInitState     :: s,   -- ^ Initial state of the game.
-               gLogicFunction :: GEnv -> s -> Event -> s,
+               gLogicFunction :: GEnv -> s -> Event -> m s,
                          -- ^ Logic function.
                gDrawFunction  :: GEnv -> s -> Plane,
                          -- ^ Draw function. Just want to blit your game
@@ -67,20 +71,23 @@ centerFull e p = blankPlaneFull e *** p
 --
 -- Need to inspect state on exit? Check 'playGameS'.
 playGame :: Game s -> IO ()
-playGame g = () <$ runGIO (runGameGeneral g)
+playGame g = () <$ playGameT T.liftIO g
+
+playGameT :: Monad m => (forall m1 a. T.MonadIO m1 => m a -> m1 a) -> GameT m s -> IO s
+playGameT trans g = runGameGeneral trans g
 
 -- | As 'playGame', but do not discard state.
 playGameS :: Game s -> IO s
-playGameS g = runGIO (runGameGeneral g)
+playGameS g = playGameT T.liftIO g
 
 -- | Tests a game in a /pure/ environment. Aims to accurately emulate 'GEnv'
 -- changes (screen size, FPS) too.
-testGame :: Game s -> GRec -> s
+testGame :: GameT Test s -> GRec -> s
-testGame g ts = fst $ runTest (runGameGeneral g) ts
+testGame g ts = fst $ runTest (runGameGeneral id g) ts
 
 -- | As 'testGame', but returns 'Game' instead of a bare state.
 -- Useful to fast-forward (e.g.: skip menus) before invoking 'playGame'.
-setupGame :: Game s -> GRec -> Game s
+setupGame :: GameT Test s -> GRec -> GameT Test s
 setupGame g ts = let s' = testGame g ts
                  in g { gInitState = s' }
                  -- xx qua messi solo [Event]?
@@ -95,39 +102,40 @@ setupGame g ts = let s' = testGame g ts
 -- record-time; this can make emulation slightly inaccurate if — e.g. —
 -- you replay the game on a smaller terminal than the one you recorded
 -- the session on.
-narrateGame :: Game s -> GRec -> IO s
+narrateGame :: GameT Narrate s -> GRec -> IO s
-narrateGame g e = runReplay (runGameGeneral g) e
+narrateGame g e = runReplay (runGameGeneral id g) e
 
 -- | Play as in 'playGame' and write the session to @file@. Useful to
 -- produce input for 'testGame' and 'narrateGame'. Session will be
 -- recorded even if an exception happens while playing.
-recordGame :: Game s -> FilePath -> IO ()
+recordGame :: GameT Record s -> FilePath -> IO ()
 recordGame g fp =
         E.bracket
           (CC.newMVar igrec)
           (\ve -> writeRec fp ve)
-          (\ve -> () <$ runRecord (runGameGeneral g) ve)
+          (\ve -> () <$ runRecord (runGameGeneral id g) ve)
 
 data Config = Config { cMEvents :: CC.MVar [Event],
                        cTPS     :: TPS }
 
-runGameGeneral :: forall s m. MonadGameIO m =>
+runGameGeneral :: forall s m1 m. (Monad m1, MonadGameIO m)
-                  Game s -> m s
+               => (forall a. m1 a -> m a)
-runGameGeneral (Game tps s lf df qf) =
+               -> GameT m1 s
+               -> m s
+runGameGeneral trans (Game tps s lf df qf) =
             -- init
             setupDisplay    >>
             startEvents tps >>= \(InputHandle ve ts) ->
-            displaySizeErr  >>= \ds ->
+            displaySizeErr  >>= \ds -> do
 
             -- do it!
-            let c = Config ve tps in
+            let c = Config ve tps
-            cleanUpErr (game c ds)
+            s' <- (game c ds) `onException` (stopEvents ts >> shutdownDisplay)
-                            -- this under will be run regardless
+            stopEvents ts
-                       (stopEvents ts >>
+            return s'
-                        shutdownDisplay  )
     where
           game :: MonadGameIO m => Config -> Dimensions -> m s
-          game c wds = gameLoop c s lf df qf
+          game c wds = gameLoop trans c s lf df qf
                                 Nothing wds
                                 (creaFPSCalc tps)
 
@@ -164,11 +172,12 @@ errorPress m = E.catches m [E.Handler errorDisplay,
 -----------
 
 -- from http://www.loomsoft.net/resources/alltut/alltut_lesson6.htm
-gameLoop :: MonadGameIO m     =>
+gameLoop :: (Monad m1, MonadGameIO m) =>
+            (forall a. m1 a -> m a) ->
             Config            -> -- event source
             s                 -> -- state
             (GEnv ->
-             s -> Event -> s) -> -- logic function
+             s -> Event -> m1 s) -> -- logic function
             (GEnv ->
              s -> Plane)      -> -- draw function
             (s -> Bool)       -> -- quit? function
@@ -176,7 +185,7 @@ gameLoop :: MonadGameIO m     =>
             Dimensions        -> -- Term dimensions
             FPSCalc           -> -- calculate fps
             m s
-gameLoop c s lf df qf opln td fps =
+gameLoop trans c s lf df qf opln td fps =
 
         -- quit?
         checkQuit qf s >>= \qb ->
@@ -190,18 +199,18 @@ gameLoop c s lf df qf opln td fps =
         -- no events? skip everything
         if null es
           then sleepABit (cTPS c)               >>
-               gameLoop c s lf df qf opln td fps
+               gameLoop trans c s lf df qf opln td fps
         else
 
         displaySizeErr            >>= \td' ->
 
         -- logic
-        let ge = GEnv td' (calcFPS fps)
+        let ge = GEnv td' (calcFPS fps) in
-            (i, s') = stepsLogic s (lf ge) es in
+        trans (stepsLogic s (lf ge) es) >>= \(i, s') ->
 
         -- no `Tick` events? You do not need to blit, just update state
         if i == 0
-          then gameLoop c s' lf df qf opln td fps
+          then gameLoop trans c s' lf df qf opln td fps
         else
 
         -- FPS calc
@@ -218,15 +227,17 @@ gameLoop c s lf df qf opln td fps =
 
         blitPlane opln' npln >>
 
-        gameLoop c s' lf df qf (Just npln) td' fps'
+        gameLoop trans c s' lf df qf (Just npln) td' fps'
 
 -- Int = number of `Tick` events
-stepsLogic :: s -> (s -> Event -> s) -> [Event] -> (Integer, s)
+stepsLogic :: Monad m => s -> (s -> Event -> m s) -> [Event] -> m (Integer, s)
-stepsLogic s lf es = let ies = D.genericLength . filter isTick $ es
+stepsLogic s lf es = do
-                     in (ies, foldl lf s es)
+  let ies = D.genericLength . filter isTick $ es
-    where
+  res <- CM.foldM lf s es
-          isTick Tick = True
+  return (ies, res)
-          isTick _    = False
+ where
+  isTick Tick = True
+  isTick _    = False
 
 -------------------------------------------------------------------------------
 -- Frame per Seconds

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/IO.hs

@@ -115,6 +115,7 @@ instance {-# OVERLAPS #-}
         (Monad m, T.MonadIO m, MC.MonadMask m, MC.MonadThrow m) =>
           MonadException m where
     cleanUpErr m c = MC.finally m c
+    onException m c = MC.onException m c
     throwExc t = MC.throwM t
 
 -----------

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Interface.hs

@@ -39,6 +39,7 @@ class Monad m => MonadTimer m where
 -- if a fails, do b (useful for cleaning up)
 class Monad m => MonadException m where
     cleanUpErr :: m a -> m b -> m a
+    onException :: m a -> m b -> m a
     throwExc :: ATGException -> m a
 
 class Monad m => MonadLogic m where

vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Test.hs

@@ -64,6 +64,7 @@ instance MonadTimer Test where
 
 instance MonadException Test where
     cleanUpErr a _ = S.tell [TCleanUpError] >> a
+    onException a _ = S.tell [TCleanUpError] >> a
     throwExc e = error . show $ e
 
 instance MonadLogic Test where