diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,12 @@ +1.3.0.0 +------- + +- `displaySize` and `playGame`/`playGameS` now throw an exception + (of type `ATGException`) instead of `error`ing. These exeptions are + `CannotGetDisplaySize` and `DisplayTooSmall`; they are synchronous, + for easier catching. (requested by sm) +- Released sab 16 ott 2021, 21:09:22 + 1.2.1.0 ------- diff --git a/ansi-terminal-game.cabal b/ansi-terminal-game.cabal --- a/ansi-terminal-game.cabal +++ b/ansi-terminal-game.cabal @@ -1,5 +1,5 @@ name: ansi-terminal-game -version: 1.2.1.0 +version: 1.3.0.0 synopsis: sdl-like functions for terminal applications, based on ansi-terminal description: Library which aims to replicate standard 2d game @@ -34,6 +34,8 @@ library exposed-modules: Terminal.Game other-modules: Terminal.Game.Animation, + Terminal.Game.Character, + Terminal.Game.Draw, Terminal.Game.Layer.Imperative, Terminal.Game.Layer.Object, Terminal.Game.Layer.Object.GameIO, @@ -42,8 +44,6 @@ Terminal.Game.Layer.Object.Narrate, Terminal.Game.Layer.Object.Record, Terminal.Game.Layer.Object.Test, - Terminal.Game.Character, - Terminal.Game.Draw, Terminal.Game.Utils, Terminal.Game.Plane, Terminal.Game.Random, @@ -94,8 +94,8 @@ Terminal.Game.Layer.Object.Test, Terminal.Game.Utils, Terminal.Game.Plane, - Terminal.Game.Random, Terminal.Game.PlaneSpec + Terminal.Game.Random build-depends: base == 4.*, ansi-terminal == 0.11.*, array == 0.5.*, diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -9,6 +9,6 @@ -- run with: cabal new-run -f examples alone main :: IO () -main = playGame aloneInARoom +main = errorPress $ playGame aloneInARoom diff --git a/src/Terminal/Game.hs b/src/Terminal/Game.hs --- a/src/Terminal/Game.hs +++ b/src/Terminal/Game.hs @@ -130,7 +130,8 @@ -- * Utility Terminal.Game.displaySize, - errorPress + errorPress, + ATGException(..) -- * Cross platform -- $threaded @@ -167,6 +168,6 @@ -- difference. -- | /Usable/ terminal display size (on Win32 console the last line is --- set aside for input). +-- set aside for input). Throws 'CannotGetDisplaySize' on error. displaySize :: IO (Width, Height) -displaySize = O.displaySize +displaySize = O.displaySizeErr diff --git a/src/Terminal/Game/Layer/Imperative.hs b/src/Terminal/Game/Layer/Imperative.hs --- a/src/Terminal/Game/Layer/Imperative.hs +++ b/src/Terminal/Game/Layer/Imperative.hs @@ -47,7 +47,10 @@ -- ghc-options: -threaded -- @ -- --- in your @.cabal@ file and you will be fine! +-- in your @.cabal@ file and you will be fine! +-- +-- Throws 'DisplayTooSmall' if game widht/height cannot be accomodated +-- by terminal. playGame :: Game s -> IO () playGame g = () <$ runGIO (runGameGeneral g) @@ -75,17 +78,8 @@ narrateGame g e = runReplay (runGameGeneral g) e -- xxx replaygame is very difficult to test --- -- | Play as in 'playGame' and write the session to @file@. Useful to --- -- produce input for 'testGame' and 'narrateGame'. --- recordGame :: Game s -> FilePath -> IO s --- recordGame g fp = --- CC.newMVar [] >>= \ve -> --- runRecord (runGameGeneral g) ve >>= \s -> --- writeMoves fp ve >> --- return s - -- | Play as in 'playGame' and write the session to @file@. Useful to --- produce input for 'testGame' and 'replayGame'. Session will be +-- produce input for 'testGame' and 'narrateGame'. Session will be -- recorded even if an exception happens while playing. recordGame :: Game s -> FilePath -> IO () recordGame g fp = @@ -101,7 +95,7 @@ Game s -> m s runGameGeneral (Game gw gh fps s lf df qf) = -- init - sizeAssert gw gh >> + sizeException gw gh >> setupDisplay >> startEvents fps >>= \(InputHandle ve ts) -> @@ -118,22 +112,30 @@ Nothing (0,0) --- | Wraps an @IO@ computation so that any 'error' gets displayed along --- with a @\@ prompt. +-- | Wraps an @IO@ computation so that any 'ATGException' or 'error' gets +-- displayed along with a @\@ prompt. -- Some terminals shut-down immediately upon program end; adding -- @errorPress@ to 'playGame' makes it easier to beta-test games on those -- terminals. errorPress :: IO a -> IO a -errorPress m = E.catch m errorDisplay +errorPress m = E.catches m [E.Handler errorDisplay, + E.Handler atgDisplay] where errorDisplay :: E.ErrorCall -> IO a - errorDisplay (E.ErrorCallWithLocation cs l) = - putStrLn "ERROR REPORT\n" >> + errorDisplay (E.ErrorCallWithLocation cs l) = report $ putStrLn (cs ++ "\n\n") >> putStrLn "Stack trace info:\n" >> - putStrLn (l ++ "\n") >> + putStrLn l - putStrLn "\n " >> + atgDisplay :: ATGException -> IO a + atgDisplay e = report $ + putStrLn (show e) + + report :: IO () -> IO a + report wm = + putStrLn "ERROR REPORT\n" >> + wm >> + putStrLn "\n\n " >> SI.hSetBuffering SI.stdin SI.NoBuffering >> getChar >> errorWithoutStackTrace "errorPress" @@ -178,7 +180,7 @@ let s' = stepsLogic s lf es in -- clear screen if resolution change - displaySize >>= \td'@(tw, th) -> + displaySizeErr >>= \td'@(tw, th) -> let resc = td /= td' in CM.when resc clearDisplay >> @@ -201,19 +203,9 @@ -- ANCILLARIES -- ----------------- -sizeAssert :: MonadDisplay m => Width -> Height -> m () -sizeAssert gw gh = - displaySize >>= \(sw, sh) -> - - let errMess = - "This games requires a screen of " ++ show gw ++ - " columns and " ++ show gh ++ " rows.\n" ++ - "Yours only has " ++ show sw ++ " columns and " ++ - show sh ++ " rows!\n\n" ++ - "Please resize your terminal and relaunch " ++ - "the game!\n" - in - +sizeException :: (MonadDisplay m, MonadException m) => Width -> Height -> m () +sizeException gw gh = + displaySizeErr >>= \(sw, sh) -> CM.when (gw > sw || gh > sh) - (error errMess) + (throwExc $ DisplayTooSmall (gw, gh) (sw, sh)) diff --git a/src/Terminal/Game/Layer/Object/IO.hs b/src/Terminal/Game/Layer/Object/IO.hs --- a/src/Terminal/Game/Layer/Object/IO.hs +++ b/src/Terminal/Game/Layer/Object/IO.hs @@ -99,9 +99,11 @@ -- Error handling -- -------------------- -instance {-# OVERLAPS #-} (Monad m, T.MonadIO m, MC.MonadMask m) => +instance {-# OVERLAPS #-} + (Monad m, T.MonadIO m, MC.MonadMask m, MC.MonadThrow m) => MonadException m where cleanUpErr m c = MC.finally m c + throwExc t = MC.throwM t ----------- @@ -124,19 +126,21 @@ blitPlane w h mp p = T.liftIO (blitPlaneIO w h mp p) shutdownDisplay = T.liftIO cleanAndExit -displaySizeIO :: IO (Width, Height) +displaySizeIO :: IO (Maybe (Width, Height)) displaySizeIO = TS.size >>= \ts -> -- cannot use ansi-terminal, on Windows you get -- "ConsoleException 87" (too much scrolling) isWin32Console >>= \bw -> - let (TS.Window h w) = maybe (error "cannot get TERM size") id ts - h' | bw = h - 1 - | otherwise = h - -- win32 console has 1 less row available than displayes - -- (it will scroll and make a mess otherwise) - in return (w, h') + return (fmap (f bw) ts) + where + f :: Bool -> TS.Window Int -> (Width, Height) + f wbw (TS.Window h w) = + let h' | wbw = h - 1 + | otherwise = h + in (w, h') + -- th tw: terminal width and height -- pn: new plane, po: old plane -- wo, ho: dimensions of the terminal. If they change, reinit double buffering @@ -194,7 +198,7 @@ clearScreen :: IO () clearScreen = CA.setCursorPosition 0 0 >> CA.setSGR [CA.Reset] >> - displaySizeIO >>= \(w, h) -> + displaySizeErr >>= \(w, h) -> CM.replicateM_ (fromIntegral $ w*h) (putChar ' ') cleanAndExit :: IO () diff --git a/src/Terminal/Game/Layer/Object/Interface.hs b/src/Terminal/Game/Layer/Object/Interface.hs --- a/src/Terminal/Game/Layer/Object/Interface.hs +++ b/src/Terminal/Game/Layer/Object/Interface.hs @@ -6,12 +6,14 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} module Terminal.Game.Layer.Object.Interface where import Terminal.Game.Plane import qualified Control.Concurrent as CC +import qualified Control.Monad.Catch as MC import qualified Data.Serialize as S import qualified GHC.Generics as G import qualified Test.QuickCheck as Q @@ -66,7 +68,26 @@ -- if a fails, do b (useful for cleaning up) class Monad m => MonadException m where cleanUpErr :: m a -> m b -> m a + throwExc :: ATGException -> m a +-- | @ATGException@s are thrown synchronously for easier catching. +data ATGException = + CannotGetDisplaySize + | DisplayTooSmall Coords Coords -- ^ Required size and actual size. + +instance Show ATGException where + show CannotGetDisplaySize = "Cannot get display size!" + show (DisplayTooSmall (gw, gh) (sw, sh)) = + "This games requires a screen of " ++ show gw ++ + " columns and " ++ show gh ++ " rows.\n" ++ + "Yours only has " ++ show sw ++ " columns and " ++ + show sh ++ " rows!\n\n" ++ + "Please resize your terminal and relaunch " ++ + "the game!\n" + +instance MC.Exception ATGException + + ----------- -- Logic -- ----------- @@ -83,7 +104,16 @@ class Monad m => MonadDisplay m where setupDisplay :: m () clearDisplay :: m () - displaySize :: m (Width, Height) -- w, h + displaySize :: m (Maybe (Width, Height)) blitPlane :: Width -> Height -> Maybe Plane -> Plane -> m () shutdownDisplay :: m () + +----------- +-- Utils -- +----------- + +displaySizeErr :: (MonadDisplay m, MonadException m) => m (Width, Height) +displaySizeErr = displaySize >>= \case + Nothing -> throwExc CannotGetDisplaySize + Just d -> return d diff --git a/src/Terminal/Game/Layer/Object/Narrate.hs b/src/Terminal/Game/Layer/Object/Narrate.hs --- a/src/Terminal/Game/Layer/Object/Narrate.hs +++ b/src/Terminal/Game/Layer/Object/Narrate.hs @@ -31,7 +31,7 @@ readRecord :: FilePath -> IO [Event] readRecord fp = S.decode <$> BS.readFile fp >>= \case Left e -> error $ "readRecord could not decode: " ++ - show e + show e Right r -> return r instance MonadInput Narrate where @@ -68,7 +68,7 @@ addEnv :: CC.MVar [Event] -> [Event] -> FPS -> IO () addEnv _ [] _ = error "fine" - -- xxx occhio qui + -- xxx occhio qui, error or throwIO? Which message? addEnv ve (e:es) fps = addEvent Nothing ve e >> CM.when (e == Tick) (CC.threadDelay delayAmount) >> diff --git a/src/Terminal/Game/Layer/Object/Test.hs b/src/Terminal/Game/Layer/Object/Test.hs --- a/src/Terminal/Game/Layer/Object/Test.hs +++ b/src/Terminal/Game/Layer/Object/Test.hs @@ -55,8 +55,7 @@ startEvents _ = S.tell [TStartEvents] >> return mockHandle pollEvents _ = Test $ S.state (\s -> (s, [])) - stopEvents _ = S.tell [TStopEvents] >> - return () + stopEvents _ = S.tell [TStopEvents] instance MonadTimer Test where getTime = return 1 @@ -64,6 +63,10 @@ instance MonadException Test where cleanUpErr a _ = S.tell [TCleanUpError] >> a + throwExc e = error . show $ e + -- we shouldn’t need strict sequencing in testing + -- xxx make it a list of TestEvent + the error + -- (not Either Err a!) instance MonadLogic Test where -- if eof, quit @@ -75,7 +78,7 @@ instance MonadDisplay Test where setupDisplay = () <$ S.tell [TSetupDisplay] clearDisplay = return () - displaySize = return (110, 11110) + displaySize = return $ Just (8000, 2400) -- xxx no display size but check display size blitPlane _ _ _ _ = return () shutdownDisplay = () <$ S.tell [TShutdownDisplay]