Auto-close modal before evaluating ModalCallback

grancalavera · Jan 12, 2019 · 7eecce5 · 7eecce5
1 parent 8ecb87e
commit 7eecce5
Show file tree

Hide file tree

Showing 10 changed files with 53 additions and 46 deletions.
diff --git a/app/Main.hs b/app/Main.hs
@@ -5,12 +5,16 @@ import           Graphics.Vty                   ( Vty )
 import qualified Graphics.Vty                  as V
 import           Lens.Micro                     ( (^.) )
 import           Data.Maybe                     ( fromMaybe )
--- import           Control.Monad                  ( void )
+
 import qualified Labyrinth.UI                  as UI
+import qualified Labyrinth.UI.Widget           as UI
 import           Labyrinth.UI                   ( Name )
-import           Labyrinth.UI.Widget
+
+import qualified Labyrinth.UI.Debug            as Debug
+
 import qualified Labyrinth.UI.Modal            as Modal
 import qualified Labyrinth.Store.Event.Modal   as Modal
+
 import qualified Labyrinth.UI.Screen.Splash    as Splash
 import qualified Labyrinth.Store.Event.Splash  as Splash
 
@@ -22,7 +26,6 @@ import           Labyrinth.Store                ( Store
                                                 , State(..)
                                                 , Ev
                                                 , state
-                                                , modal
                                                 )
 
 main :: IO ()
@@ -39,13 +42,13 @@ app = App { appDraw         = draw
           }
 
 draw :: Store e -> [Widget Name]
-draw store = [showModals, maybe drawScreen Modal.draw (Store.nextModal store)]
+draw store =
+  [Debug.draw store, maybe drawScreen Modal.draw (Store.nextModal store)]
  where
-  showModals = str $ show (store ^. modal)
-  drawScreen = appContainer 50 $ case store ^. state of
+  drawScreen = UI.appContainer 50 $ case store ^. state of
     Splash s -> Splash.draw s
     Setup  s -> Setup.draw s
-    _        -> emptyWidget
+    _        -> txt "Screen not implemented"
 
 handleEvent
   :: Ord e => Store e -> BrickEvent Name e -> EventM Name (Next (Store e))
@@ -69,6 +72,5 @@ chooseCursor store =
   fromMaybe (neverShowCursor store) $ if Store.isShowingModal store
     then Store.nextModal store >>= Modal.chooseCursor
     else case store ^. state of
-      Splash s -> Splash.chooseCursor s
-      Setup  s -> Setup.chooseCursor s
-      _        -> Nothing
+      Setup s -> Setup.chooseCursor s
+      _       -> Nothing
diff --git a/labyrinth.cabal b/labyrinth.cabal
@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: c4ecded4a317515194ffec780399ead781fb6980bb83fc4782fe5aa4ec1d9811
+-- hash: 6cbcea1f571593f670a43c58a89b3e50fcc26e29adcc1665118ae3f7c365c410
 
 name:           labyrinth
 version:        0.1.0.0
@@ -30,6 +30,7 @@ library
       Labyrinth.Game.Players
       Labyrinth.UI
       Labyrinth.UI.Modal
+      Labyrinth.UI.Debug
       Labyrinth.UI.Screen.Splash
       Labyrinth.UI.Screen.Setup
       Labyrinth.UI.Screen.Game

diff --git a/lib/Labyrinth/Store.hs b/lib/Labyrinth/Store.hs
@@ -3,7 +3,7 @@ module Labyrinth.Store
   , State(..)
   , Ev
   , state
-  , modal
+  , modals
   , initial
   , isModalEvent
   , isShowingModal
@@ -19,10 +19,10 @@ import           Labyrinth.UI                   ( Name )
 import qualified Labyrinth.UI.Screen.Splash    as Splash
 
 initial :: Store e
-initial = Store { _state = Splash Splash.initial, _modal = [] }
+initial = Store { _state = Splash Splash.initial, _modals = [] }
 
 isModalEvent :: Ord e => Store e -> BrickEvent Name e -> Bool
 isModalEvent store ev = isShowingModal store || Modal.isModalEvent ev
 
 isShowingModal :: Store e -> Bool
-isShowingModal = not . null . (^. modal)
+isShowingModal = not . null . (^. modals)
diff --git a/lib/Labyrinth/Store/Event/Modal.hs b/lib/Labyrinth/Store/Event/Modal.hs
@@ -1,6 +1,8 @@
 module Labyrinth.Store.Event.Modal
   ( handle
   , isModalEvent
+  , showModal
+  , nextModal
   )
 where
 
@@ -17,7 +19,9 @@ import           Data.Map.Strict                ( Map
                                                 , (!?)
                                                 )
 import           Data.Maybe                     ( fromMaybe )
-import           Labyrinth.UI                   ( Name )
+import           Labyrinth.UI                   ( Name
+                                                , ModalCallback
+                                                )
 import           Labyrinth.UI.Modal             ( dialog
                                                 , onTrue
                                                 , onFalse
@@ -38,13 +42,15 @@ handleInModal :: GlobalEventHandler e
 handleInModal store ev = maybe (continue store) withModal (nextModal store)
  where
   withModal m = case ev of
-    (VtyEvent (V.EvKey V.KEsc   [])) -> (m ^. onFalse) store
+    (VtyEvent (V.EvKey V.KEsc   [])) -> (hideModalAnd $ m ^. onFalse) store
     (VtyEvent (V.EvKey V.KEnter [])) -> fromMaybe (continue store) $ do
       sel <- D.dialogSelection (m ^. dialog)
-      return $ if sel then (m ^. onTrue) store else (m ^. onFalse) store
+      return $ if sel
+        then (hideModalAnd $ m ^. onTrue) store
+        else (hideModalAnd $ m ^. onFalse) store
     (VtyEvent vtyEv) -> do
       d <- D.handleDialogEvent vtyEv (m ^. dialog)
-      continue $ store & modal %~ \case
+      continue $ store & modals %~ \case
         []       -> []
         (_ : ms) -> (m & dialog .~ d) : ms
     _ -> continue store
@@ -55,8 +61,13 @@ promptToQuit store _ = showModal store $ mkModal
   (txt "Do you want to quit Labyrinth?")
   (0, [("Stay", False), ("Quit", True)])
   halt
-  hideModal
+  continue
 
 eventMap :: Ord e => Map (BrickEvent Name e) (GlobalEventHandler e)
 eventMap =
   Map.fromList [(VtyEvent (V.EvKey (V.KChar 'q') [V.MCtrl]), promptToQuit)]
+
+hideModalAnd :: ModalCallback Store e -> ModalCallback Store e
+hideModalAnd f store = f $ store & modals %~ \case
+  []       -> []
+  (_ : ms) -> ms
diff --git a/lib/Labyrinth/Store/Event/Setup.hs b/lib/Labyrinth/Store/Event/Setup.hs
@@ -46,7 +46,7 @@ play :: RegistrationEventHandler e
 play s store _ = maybe (continue store) promptToPlay (S.setup s)
  where
   promptToPlay (p, ps) = showModal store
-    $ UI.mkOkModal "start" (UI.nextPlayerPrompt p) (toNewGame p ps)
+    $ UI.mkOkModal "start" (UI.nextPlayerPrompt p) (continueToNewGame p ps)
 
 processInput :: RegistrationEventHandler e
 processInput s store ev =
@@ -59,5 +59,6 @@ edit i s store _ =
 update :: Store e -> SetupS e -> Store e
 update store s = store & state .~ Setup s
 
-toNewGame :: Player -> Players -> ModalCallback Store e
-toNewGame p ps store = continue $ store & state .~ Plan (G.initial (Game ps p))
+continueToNewGame :: Player -> Players -> ModalCallback Store e
+continueToNewGame p ps store =
+  continue $ store & state .~ Plan (G.initial (Game ps p))
diff --git a/lib/Labyrinth/Store/Internal.hs b/lib/Labyrinth/Store/Internal.hs
@@ -4,9 +4,8 @@ module Labyrinth.Store.Internal
   , Ev
   , EventHandler
   , state
-  , modal
+  , modals
   , showModal
-  , hideModal
   , nextModal
   )
 where
@@ -36,19 +35,14 @@ data State e = Splash SplashS
 
 data Store e = Store
   { _state :: State e
-  , _modal :: [Modal Store e]
+  , _modals :: [Modal Store e]
   } deriving (Show)
 makeLenses ''Store
 type EventHandler s e
   = s -> Store e -> BrickEvent Name e -> EventM Name (Next (Store e))
 
 showModal :: Store e -> Modal Store e -> EventM Name (Next (Store e))
-showModal store m = continue $ store & modal %~ (m :)
-
-hideModal :: Store e -> EventM Name (Next (Store e))
-hideModal store = continue $ store & modal %~ \case
-  []       -> []
-  (_ : ms) -> ms
+showModal store m = continue $ store & modals %~ (m :)
 
 nextModal :: Store e -> Maybe (Modal Store e)
-nextModal = listToMaybe . (^. modal)
+nextModal = listToMaybe . (^. modals)
diff --git a/lib/Labyrinth/UI/Debug.hs b/lib/Labyrinth/UI/Debug.hs
@@ -6,14 +6,16 @@ where
 import           Brick
 import           Lens.Micro                     ( (^.) )
 import qualified Labyrinth.Store               as S
-import           Labyrinth.Store                ( Store, State(..) )
+import           Labyrinth.Store                ( Store
+                                                , State(..)
+                                                )
 
 draw :: Store e -> Widget n
 draw store = vBox [state, modals]
-  where
-    state = txt $ case (store ^. S.state) of
-      Splash _ -> "State: Splash"
-      Setup _ -> "State: Setup"
-      Plan _ -> "State: Plan"
-      _ -> "State: not implemented"
-    modals = str $ show $ store ^. S.modal
+ where
+  state = txt . ("State: " <>) $ case store ^. S.state of
+    Splash _ -> "Splash"
+    Setup  _ -> "Setup"
+    Plan   _ -> "Plan"
+    _        -> "not implemented"
+  modals = str $ show $ store ^. S.modals
diff --git a/lib/Labyrinth/UI/Modal.hs b/lib/Labyrinth/UI/Modal.hs
@@ -60,4 +60,4 @@ mkModal desc body options onT onF = Modal
   }
 
 mkOkModal :: String -> Widget Name -> ModalCallback s e -> Modal s e
-mkOkModal desc body onOk = mkModal desc body (0, [("OK", True)]) onOk onOk
+mkOkModal desc body onOk = mkModal desc body (0, [("OK", True)]) onOk continue
diff --git a/lib/Labyrinth/UI/Screen/Splash.hs b/lib/Labyrinth/UI/Screen/Splash.hs
@@ -2,7 +2,6 @@ module Labyrinth.UI.Screen.Splash
   ( draw
   , SplashS
   , initial
-  , chooseCursor
   )
 where
 
@@ -30,7 +29,3 @@ draw _ =
 
 initial :: SplashS
 initial = SplashS
-
-chooseCursor
-  :: SplashS -> Maybe ([CursorLocation Name] -> Maybe (CursorLocation Name))
-chooseCursor _ = Nothing
diff --git a/package.yaml b/package.yaml
@@ -33,6 +33,7 @@ library:
     - Labyrinth.Game.Players
     - Labyrinth.UI
     - Labyrinth.UI.Modal
+    - Labyrinth.UI.Debug
     - Labyrinth.UI.Screen.Splash
     - Labyrinth.UI.Screen.Setup
     - Labyrinth.UI.Screen.Game