allow player creation callbacks to be impure

src/Mtlstats/Actions.hs

@@ -34,6 +34,7 @@ module Mtlstats.Actions
   , addPlayer
   ) where
 
+import Control.Monad.Trans.State (modify)
 import Data.Maybe (fromMaybe)
 import Data.Time.Calendar (fromGregorianValid)
 import Lens.Micro (over, (^.), (&), (.~), (?~), (%~), (+~))
@@ -117,7 +118,7 @@ validateGameDate s = fromMaybe s $ do
 -- | Starts player creation mode
 createPlayer :: ProgState -> ProgState
 createPlayer = let
-  cb = progMode .~ MainMenu
+  cb = modify $ progMode .~ MainMenu
   cps
     = newCreatePlayerState
     & cpsSuccessCallback .~ cb

src/Mtlstats/Control.hs

@@ -21,7 +21,7 @@ along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
 module Mtlstats.Control (dispatch) where
 
-import Control.Monad (when)
+import Control.Monad (join, when)
 import Control.Monad.Trans.State (gets, modify)
 import Data.Char (toUpper)
 import Data.Maybe (fromJust)
@@ -238,10 +238,9 @@ confirmCreatePlayerC = Controller
     case ynHandler e of
       Just True -> do
         modify addPlayer
-        gets (view $ progMode.createPlayerStateL.cpsSuccessCallback)
-          >>= modify
-      Just False -> gets (view $ progMode.createPlayerStateL.cpsFailureCallback)
-        >>= modify
+        join $ gets $ view $ progMode.createPlayerStateL.cpsSuccessCallback
+      Just False ->
+        join $ gets $ view $ progMode.createPlayerStateL.cpsFailureCallback
       Nothing -> return ()
     return True
   }

src/Mtlstats/Types.hs

@@ -217,9 +217,9 @@ data CreatePlayerState = CreatePlayerState
   -- ^ The player's name
   , _cpsPosition        :: String
   -- ^ The player's position
-  , _cpsSuccessCallback :: ProgState -> ProgState
+  , _cpsSuccessCallback :: Action ()
   -- ^ The function to call on success
-  , _cpsFailureCallback :: ProgState -> ProgState
+  , _cpsFailureCallback :: Action ()
   -- ^ The function to call on failure
   }
 
@@ -495,8 +495,8 @@ newCreatePlayerState = CreatePlayerState
   { _cpsNumber          = Nothing
   , _cpsName            = ""
   , _cpsPosition        = ""
-  , _cpsSuccessCallback = id
-  , _cpsFailureCallback = id
+  , _cpsSuccessCallback = return ()
+  , _cpsFailureCallback = return ()
   }
 
 -- | Constructor for a 'Database'