diff --git a/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game.hs b/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game.hs index c1bc144..f74d6d0 100644 --- a/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game.hs +++ b/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 diff --git a/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Imperative.hs b/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Imperative.hs index 6c6c8bb..00b4021 100644 --- a/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Imperative.hs +++ b/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 g ts = fst $ runTest (runGameGeneral g) ts +testGame :: GameT Test s -> GRec -> s +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 g e = runReplay (runGameGeneral g) e +narrateGame :: GameT Narrate s -> GRec -> IO s +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 => - Game s -> m s -runGameGeneral (Game tps s lf df qf) = +runGameGeneral :: forall s m1 m. (Monad m1, MonadGameIO m) + => (forall a. m1 a -> m a) + -> 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 - cleanUpErr (game c ds) - -- this under will be run regardless - (stopEvents ts >> - shutdownDisplay ) + let c = Config ve tps + s' <- (game c ds) `onException` (stopEvents ts >> shutdownDisplay) + stopEvents ts + return s' 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) - (i, s') = stepsLogic s (lf ge) es in + let ge = GEnv td' (calcFPS fps) 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 s lf es = let ies = D.genericLength . filter isTick $ es - in (ies, foldl lf s es) - where - isTick Tick = True - isTick _ = False +stepsLogic :: Monad m => s -> (s -> Event -> m s) -> [Event] -> m (Integer, s) +stepsLogic s lf es = do + let ies = D.genericLength . filter isTick $ es + res <- CM.foldM lf s es + return (ies, res) + where + isTick Tick = True + isTick _ = False ------------------------------------------------------------------------------- -- Frame per Seconds diff --git a/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/IO.hs b/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/IO.hs index bbe8aa1..7e058fc 100644 --- a/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/IO.hs +++ b/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 ----------- diff --git a/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Interface.hs b/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Interface.hs index 0994066..2b55788 100644 --- a/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Interface.hs +++ b/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 diff --git a/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Test.hs b/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Test.hs index 7e263c1..ff64117 100644 --- a/vendored/ansi-terminal-game-1.8.0.0/src/Terminal/Game/Layer/Object/Test.hs +++ b/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