From 219379393ed26d25de7069d7bb2c110aeba367d9 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 30 Oct 2022 16:11:30 +0000 Subject: [PATCH] Remove a lot of IO/maybe cruft --- src/Dodge/Data/Universe.hs | 10 +++--- src/Dodge/Debug/Terminal.hs | 64 ++++++++++++++++++------------------ src/Dodge/Event.hs | 2 +- src/Dodge/Event/Keyboard.hs | 18 +++++----- src/Dodge/Event/Menu.hs | 13 ++++---- src/Dodge/Menu.hs | 52 ++++++++++++++--------------- src/Dodge/Menu/Option.hs | 2 +- src/Dodge/Menu/OptionType.hs | 4 +-- src/Dodge/Menu/PushPop.hs | 13 +++----- 9 files changed, 85 insertions(+), 93 deletions(-) diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index d6932ce40..ad627efc9 100644 --- a/src/Dodge/Data/Universe.hs +++ b/src/Dodge/Data/Universe.hs @@ -49,7 +49,7 @@ data ScreenLayer = OptionScreen { _scTitle :: Universe -> String , _scOptions :: [MenuOption] - , _scDefaultEff :: Universe -> IO (Maybe Universe) + , _scDefaultEff :: Universe -> Universe , _scOptionFlag :: OptionScreenFlag , _scOptionsOffset :: Int } @@ -77,20 +77,20 @@ data MenuOptionDisplay data MenuOption = Toggle - { _moEff :: Universe -> IO (Maybe Universe) + { _moEff :: Universe -> Universe , _moString :: Universe -> MenuOptionDisplay , _moKey :: Scancode } | Toggle2 { _moKey1 :: Scancode - , _moEff1 :: Universe -> IO (Maybe Universe) + , _moEff1 :: Universe -> Universe , _moKey2 :: Scancode - , _moEff2 :: Universe -> IO (Maybe Universe) + , _moEff2 :: Universe -> Universe , _moString :: Universe -> MenuOptionDisplay } | InvisibleToggle { _moKey :: Scancode - , _moEff :: Universe -> IO (Maybe Universe) + , _moEff :: Universe -> Universe } data IntID a = IntID Int a diff --git a/src/Dodge/Debug/Terminal.hs b/src/Dodge/Debug/Terminal.hs index a862f39ee..8dd7e1dfa 100644 --- a/src/Dodge/Debug/Terminal.hs +++ b/src/Dodge/Debug/Terminal.hs @@ -5,15 +5,15 @@ module Dodge.Debug.Terminal where import Dodge.Item.Location.Initialize import Control.Applicative import Control.Lens -import Control.Monad -import Data.List +--import Control.Monad +--import Data.List import Data.Maybe import qualified Data.Text as T import Dodge.Creature import Dodge.Data.Universe import Dodge.Inventory.Add import Dodge.Item -import Dodge.Menu.PushPop +--import Dodge.Menu.PushPop import qualified IntMapHelp as IM import LensHelp import MaybeHelp @@ -75,35 +75,35 @@ applySetTerminalString var = case key' of val' = readMaybe val :: Maybe Float key' = if isNothing val' then "" else key -autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe) -autoCompleteTerminal s _ = - return - . (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands)) - where - (key, val) = getSplitString $ tail s - command_options = case val of - "" -> filter (isInfixOf key) (validTerminalCommands "") - _ -> filter (isInfixOf val) (validTerminalCommands key) - -- basic autocomplete if single option available (or as far as possible) - input_str = case (key, val) of - (_, "") -> - if length command_options == 1 - then ">" ++ head command_options ++ " " - else ">" ++ longestCommonPrefix command_options - _ -> - if length command_options == 1 - then ">" ++ key ++ " " ++ head command_options ++ " " - else - if null command_options - then s - else ">" ++ key ++ " " ++ longestCommonPrefix command_options - command_options' = - if not (null command_options) && head command_options == key - then validTerminalCommands key - else command_options - - --val' = Debug.Trace.trace key tail val - valid_commands = "Options: " ++ intercalate ", " command_options' +--autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe) +--autoCompleteTerminal s _ = +-- return +-- . (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands)) +-- where +-- (key, val) = getSplitString $ tail s +-- command_options = case val of +-- "" -> filter (isInfixOf key) (validTerminalCommands "") +-- _ -> filter (isInfixOf val) (validTerminalCommands key) +-- -- basic autocomplete if single option available (or as far as possible) +-- input_str = case (key, val) of +-- (_, "") -> +-- if length command_options == 1 +-- then ">" ++ head command_options ++ " " +-- else ">" ++ longestCommonPrefix command_options +-- _ -> +-- if length command_options == 1 +-- then ">" ++ key ++ " " ++ head command_options ++ " " +-- else +-- if null command_options +-- then s +-- else ">" ++ key ++ " " ++ longestCommonPrefix command_options +-- command_options' = +-- if not (null command_options) && head command_options == key +-- then validTerminalCommands key +-- else command_options +-- +-- --val' = Debug.Trace.trace key tail val +-- valid_commands = "Options: " ++ intercalate ", " command_options' getSplitString :: [Char] -> ([Char], [Char]) getSplitString str = case break (== ' ') str of diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 551b1f4ce..67de65828 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -24,7 +24,7 @@ import SDL handleEvent :: Event -> Universe -> IO (Maybe Universe) handleEvent e = case eventPayload e of TextInputEvent tev -> return . Just . handleTextInput (textInputEventText tev) - KeyboardEvent kev -> handleKeyboardEvent kev + KeyboardEvent kev -> return . Just . handleKeyboardEvent kev MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev MouseButtonEvent mbev -> return . Just . over uvWorld (handleMouseButtonEvent mbev) MouseWheelEvent mwev -> return . handleMouseWheelEvent mwev diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 61b07d886..468b9b26d 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -47,9 +47,9 @@ On release, remove scancode from the 'Set' of pressed keys. On press, adds the scancode, and perhaps applies a direct effect: see 'handlePressedKeyInGame'. -} -handleKeyboardEvent :: KeyboardEventData -> Universe -> IO (Maybe Universe) +handleKeyboardEvent :: KeyboardEventData -> Universe -> Universe handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of - Released -> return . Just $ u & uvWorld . input . pressedKeys . at scode .~ Nothing + Released -> u & uvWorld . input . pressedKeys . at scode .~ Nothing Pressed -> handlePressedKey (keyboardEventRepeat kev) @@ -61,17 +61,17 @@ handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of | otherwise = InitialPress scode = (keysymScancode . keyboardEventKeysym) kev -handlePressedKey :: Bool -> Scancode -> Universe -> IO (Maybe Universe) -handlePressedKey True _ u = return $ Just u +handlePressedKey :: Bool -> Scancode -> Universe -> Universe +handlePressedKey True _ u = u handlePressedKey _ scode u = case scode of - ScancodeF5 -> return . Just $ doQuicksave u - ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u - ScancodeSemicolon -> return . Just $ gotoTerminal u + ScancodeF5 -> doQuicksave u + ScancodeF9 -> loadSaveSlot QuicksaveSlot u + ScancodeSemicolon -> gotoTerminal u _ | null (_uvScreenLayers u) -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> - return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u - _ -> return $ Just u + over uvWorld (handlePressedKeyTerminal tmid scode) u + _ -> u _ -> handlePressedKeyInMenu (head $ _uvScreenLayers u) scode u handlePressedKeyTerminal :: Int -> Scancode -> World -> World diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index a6b1c9036..9d24bec9e 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -8,24 +8,23 @@ import Dodge.Data.Universe import Dodge.WindowLayout import SDL -handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe) +handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> Universe handlePressedKeyInMenu mState scode = case mState of OptionScreen{_scOptions = mos, _scDefaultEff = defeff} -> optionListToEffects defeff scode mos --DisplayScreen{} -> popScreen -- WaitScreen{} -> return . Just - _ -> return . Just + _ -> id optionListToEffects :: - (Universe -> IO (Maybe Universe)) -> + (Universe -> Universe) -> Scancode -> [MenuOption] -> Universe -> - IO (Maybe Universe) + Universe optionListToEffects defaulteff sc mops u = case sc of ScancodeSpace -> - return . Just - . (uvScreenLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines))) + (uvScreenLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines))) $ u _ -> ( fromMaybe defaulteff @@ -40,7 +39,7 @@ optionListToEffects defaulteff sc mops u = case sc of | otherwise = x mlines = availableMenuLines $ _uvConfig u -menuOptionToEffects :: MenuOption -> [(Scancode, Universe -> IO (Maybe Universe))] +menuOptionToEffects :: MenuOption -> [(Scancode, Universe -> Universe)] menuOptionToEffects Toggle{_moKey = k, _moEff = eff} = [(k, eff)] menuOptionToEffects InvisibleToggle{_moKey = k, _moEff = eff} = [(k, eff)] menuOptionToEffects diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index d9e9d6b17..fd7410ae0 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -25,20 +25,20 @@ import Data.Maybe splashMenu :: ScreenLayer splashMenu = - slTitleOptionsEff "AMNESIS" splashMenuOptions (return . Just) + slTitleOptionsEff "AMNESIS" splashMenuOptions id & scOptionFlag .~ SplashOptions splashMenuOptions :: [MenuOption] splashMenuOptions = basicKeyOptions - [ Toggle (return . Just . loadSaveSlot (SaveSlotNum 0)) displaycontinue - , Toggle (return . Just . startNewGameInSlot 0) (opText "NEW WITH RANDOM SEED") - , Toggle (return . Just . reloadLevelStart) (displaywhenseed "NEW WITH LAST SEED") + [ Toggle ( loadSaveSlot (SaveSlotNum 0)) displaycontinue + , Toggle ( startNewGameInSlot 0) (opText "NEW WITH RANDOM SEED") + , Toggle ( reloadLevelStart) (displaywhenseed "NEW WITH LAST SEED") , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW WITH SPECIFIC SEED") , Toggle (pushScreen optionMenu) (opText "OPTIONS") , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS") - , Toggle (return . Just) (displaywhenseed "VIEW LAST SEED") - , Toggle (return . const Nothing) (opText "QUIT") + , Toggle (id) (displaywhenseed "VIEW LAST SEED") + , Toggle (id) (opText "QUIT") ] where opText = const . MODString @@ -48,30 +48,27 @@ splashMenuOptions = | otherwise = MODString str pauseMenu :: ScreenLayer -pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause) +pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (unpause) pauseMenuOptions :: [MenuOption] pauseMenuOptions = basicKeyOptions [ Toggle popScreen (opText "CONTINUE") - , Toggle (return . Just . startNewGameInSlot 0) (opText "NEW GAME") - , Toggle (return . Just . reloadLevelStart) (opText "RESTART") + , Toggle (startNewGameInSlot 0) (opText "NEW GAME") + , Toggle (reloadLevelStart) (opText "RESTART") , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW FROM SEED") , Toggle (pushScreen optionMenu) (opText "OPTIONS") , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS") - , Toggle (return . Just) (opText "VIEW CURRENT SEED") + , Toggle id (opText "VIEW CURRENT SEED") , Toggle saveQuit (opText "SAVE AND QUIT") ] - ++ [ InvisibleToggle ScancodeEscape (return . const Nothing) + ++ [ InvisibleToggle ScancodeEscape id ] where opText = const . MODString -saveQuit :: Universe -> IO (Maybe Universe) -saveQuit u = - return $ - Just $ - u & addSideEffect (saveQuitConc u) "SAVING" +saveQuit :: Universe -> Universe +saveQuit u = u & addSideEffect (saveQuitConc u) "SAVING" saveQuitConc :: Universe -> IO (Universe -> Maybe Universe) saveQuitConc u = do @@ -83,19 +80,19 @@ seedStartMenu str = slTitleOptionsEff str seedStartOptions popScreen seedStartOptions :: [MenuOption] seedStartOptions = - [ Toggle trySeedFromClipboard (const $ MODString "PASTE NUMBER FROM CLIPBOARD") ScancodeA + [ Toggle (uvIOEffects .~ trySeedFromClipboard) (const $ MODString "PASTE NUMBER FROM CLIPBOARD") ScancodeA -- , Toggle ScancodeI (return . Just . loadSaveSlot LevelStartSlot) (const "INSERT NUMBER") ] -trySeedFromClipboard :: Universe -> IO (Maybe Universe) +trySeedFromClipboard :: Universe -> IO Universe trySeedFromClipboard u = do mcstr <- getClipboardString case mcstr >>= readMaybe of Nothing -> - pushScreen + return $ pushScreen (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER") (u & uvScreenLayers %~ tail) - Just i -> return . Just $ startSeedGame 0 i u + Just i -> return $ startSeedGame 0 i u slTitleOptions :: String -> [MenuOption] -> ScreenLayer slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig) @@ -122,13 +119,13 @@ debugMenuOptions :: [MenuOption] debugMenuOptions = zipWith ($) - (map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" return]) + (map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" id]) $ map Scancode [4 ..] where f :: DebugBool -> Scancode -> MenuOption f bd = Toggle - (return . Just . (uvConfig . debug_booleans . at bd %~ toggleJust)) + ((uvConfig . debug_booleans . at bd %~ toggleJust)) (uncurry MODStringOption . g bd . (^? uvConfig . debug_booleans . ix bd)) g bd Nothing = (show bd, "False") g bd _ = (show bd, "True") @@ -182,7 +179,8 @@ soundMenuOptions = scod2 (change inc stype) (\w -> MODStringOption str (leftPad 2 '.' $ show (round $ 10 * voltype (_uvConfig w) :: Int))) - change g vt uv = sw uv >> return (Just $ uv & uvConfig . vt %~ g) + change g vt uv = uv & uvConfig . vt %~ g + & uvIOEffects .~ \u -> sw uv >> return u dec x = max 0 (x - 0.1) inc x = min 1 (x + 0.1) sw w = setVol (_uvConfig w) @@ -196,7 +194,7 @@ graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions graphicsMenuOptions :: [MenuOption] graphicsMenuOptions = basicKeyOptions - [ makeEnumOption graphics_resolution_factor "RESOLUTION" updateFramebufferSize + [ makeEnumOption graphics_resolution_factor "RESOLUTION" (uvIOEffects .~ updateFramebufferSize) , makeBoolOption graphics_wall_textured "WALL TEXTURES" , makeBoolOption graphics_object_shadows "OBJECT SHADOWS" , makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS" @@ -204,7 +202,7 @@ graphicsMenuOptions = gameOverMenu :: ScreenLayer gameOverMenu = - slTitleOptionsEff "GAME OVER" pauseMenuOptions (return . Just) + slTitleOptionsEff "GAME OVER" pauseMenuOptions id & scOptionFlag .~ GameOverOptions -- OptionScreen @@ -218,8 +216,8 @@ gameOverMenu = --charToScode :: Char -> Scancode --charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum -unpause :: Universe -> Maybe Universe -unpause w = Just . resumeSound $ w & uvScreenLayers .~ [] +unpause :: Universe -> Universe +unpause w = resumeSound $ w & uvScreenLayers .~ [] displayControls :: ScreenLayer displayControls = ColumnsScreen (const "CONTROLS") listControls diff --git a/src/Dodge/Menu/Option.hs b/src/Dodge/Menu/Option.hs index 8e263c206..bb70558dd 100644 --- a/src/Dodge/Menu/Option.hs +++ b/src/Dodge/Menu/Option.hs @@ -2,7 +2,7 @@ module Dodge.Menu.Option where import Dodge.Data.Universe -slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> IO (Maybe Universe)) -> ScreenLayer +slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> Universe) -> ScreenLayer slTitleOptionsEff title ops eff = OptionScreen { _scTitle = const title diff --git a/src/Dodge/Menu/OptionType.hs b/src/Dodge/Menu/OptionType.hs index 9b27b1eab..233f1b9ab 100644 --- a/src/Dodge/Menu/OptionType.hs +++ b/src/Dodge/Menu/OptionType.hs @@ -7,12 +7,12 @@ import Dodge.Menu.PushPop makeBoolOption lns t = Toggle - (return . Just . (uvConfig . lns #%~ not)) + (uvConfig . lns #%~ not) (\u -> MODStringOption t (show (u ^# uvConfig . lns))) makeEnumOption lns str sideeff = Toggle - (\u -> Just <$> sideeff (u & uvConfig . lns #%~ cycleEnum)) + (\u -> sideeff (u & uvConfig . lns #%~ cycleEnum)) (\u -> MODStringOption str (show (u ^# uvConfig . lns))) makeSubmenuOption submenu t = Toggle (pushScreen submenu) (const t) diff --git a/src/Dodge/Menu/PushPop.hs b/src/Dodge/Menu/PushPop.hs index beb825099..7fad6cb9c 100644 --- a/src/Dodge/Menu/PushPop.hs +++ b/src/Dodge/Menu/PushPop.hs @@ -3,14 +3,9 @@ module Dodge.Menu.PushPop where import Dodge.Data.Universe import LensHelp -popScreen' :: Universe -> Maybe Universe -popScreen' = Just . (uvScreenLayers %~ tail) +popScreen :: Universe -> Universe +popScreen = uvScreenLayers %~ tail -popScreen :: Universe -> IO (Maybe Universe) -popScreen = return . popScreen' +pushScreen :: ScreenLayer -> Universe -> Universe +pushScreen ml = (uvScreenLayers .:~ ml) -pushScreen' :: ScreenLayer -> Universe -> Maybe Universe -pushScreen' ml = Just . (uvScreenLayers .:~ ml) - -pushScreen :: ScreenLayer -> Universe -> IO (Maybe Universe) -pushScreen ml = return . pushScreen' ml