Closing windows with or Cmd-W

TODOs.txt

@@ -17,8 +17,6 @@ Game 136: White's partner won 1-0\n
 TextMessage "Ambiguous move (nd2).\n"
 
 
--- Close window/frames with CMD-W
-
 -- use pending from / to for in-game messages?
 -- ie: Pending (PendingOffer {origin = From, offerId = 3, playerName = UserHandle {name = "GuestFWXZ", handleType = []}, offerType = "abort", params = "#"})
 

src/Macbeth/Wx/Configuration.hs

@@ -8,6 +8,7 @@ import Macbeth.Wx.RuntimeEnv
 import Macbeth.Wx.Utils
 import qualified Macbeth.Wx.Config.UserConfig as C
 
+import Control.Monad.Cont
 import Control.Concurrent.Chan
 import Control.Monad.Except
 import Graphics.UI.WX hiding (fontSize)
@@ -18,25 +19,32 @@ import qualified Data.Yaml as Y
 
 
 wxConfiguration :: RuntimeEnv -> Chan FicsMessage -> IO ()
-wxConfiguration env chan = do
-  f  <- frame [ text := "Macbeth (" ++ getVersion env ++ ")"]
-  ct <- textCtrlEx f (wxTE_MULTILINE .+. wxTE_RICH) [font := fontFixed]
+wxConfiguration env chan = runCont (basicFrame (frameConfig env) chan) setupFrame
+
+
+frameConfig :: RuntimeEnv -> FrameConfig
+frameConfig env = FrameConfig {
+  fCreate = frame,
+  fTitle = "Macbeth (" ++ getVersion env ++ ")",
+  hasStatusField = True
+}
+
+
+setupFrame :: (Panel (), StatusField, FrameActions) -> IO ()
+setupFrame (p, status, _) = do
+  ct <- textCtrlEx p (wxTE_MULTILINE .+. wxTE_RICH) [font := fontFixed]
   showConfig ct
-  status <- statusField []
 
-  b_current <- button f [text := "Reset", on command := showConfig ct]
-  b_resetSounds <- button f [text := "Reset Sounds", on command := resetSounds ct]
-  b_save <- button f [ text := "Save",
+  b_current <- button p [text := "Reset", on command := showConfig ct]
+  b_resetSounds <- button p [text := "Reset Sounds", on command := resetSounds ct]
+  b_save <- button p [ text := "Save",
                        on command := either (\_ -> set status [text := "Illegal file format."]) return
                                      =<< runExceptT (parseAndSave ct status)]
 
-
-  set f [ statusBar := [status],
-          layout := margin 10 $ column 10 [
-                       boxed "Configuration" $ fill $ minsize (Size 380 220) $ widget ct
+  set p [ layout :=  margin 10 $ column 10 [
+                       boxed "Configuration" $ fill $ minsize (Size 440 480) $ widget ct
                      , hfloatRight $ row 5 [widget b_current, widget b_resetSounds, widget b_save]]
         ]
-  registerWxCloseEventListener f chan
 
 
 showConfig :: TextCtrl() -> IO ()

src/Macbeth/Wx/Finger.hs

@@ -6,17 +6,30 @@ import Macbeth.Fics.FicsMessage
 import Macbeth.Fics.Api.Player
 import Macbeth.Wx.Utils
 
+import Control.Monad.Cont
 import Control.Concurrent.Chan
 import Graphics.UI.WX
 
+
 wxInfo :: FicsMessage -> Chan FicsMessage -> IO ()
-wxInfo msg chan = do
-  f <- frameFixed [ text := title msg]
-  st <- staticText f [ text := showAll msg
+wxInfo msg chan = runCont (basicFrame (frameConfig msg) chan) $ setupFrame msg
+
+
+frameConfig :: FicsMessage -> FrameConfig
+frameConfig msg = FrameConfig {
+  fCreate = frameFixed,
+  fTitle = title msg,
+  hasStatusField = False
+}
+
+
+setupFrame :: FicsMessage -> (Panel (), StatusField, FrameActions) -> IO ()
+setupFrame msg (p, _, _) = do
+  st <- staticText p [ text := showAll msg
                      , font := fontFixed
                      , fontSize := 14]
-  set f [layout := margin 10 $ row 0 [widget st]]
-  registerWxCloseEventListener f chan
+  set p [layout := margin 10 $ row 0 [widget st]]
+
 
 title :: FicsMessage -> String
 title (Finger userHandle _) = "Finger of " ++ name userHandle

src/Macbeth/Wx/Match.hs

@@ -7,6 +7,7 @@ import Macbeth.Wx.GameType
 import Macbeth.Wx.Utils
 
 import Control.Concurrent.Chan
+import Control.Monad.Cont
 import Data.Map
 import Data.Char
 import Graphics.UI.WX hiding (color)
@@ -24,17 +25,27 @@ data WxMatch = WxMatch {
 }
 
 wxMatch :: Handle -> Bool -> Chan FicsMessage -> IO ()
-wxMatch h isGuest chan = do
-  f <- frameFixed [ text := "Create a match" ]
-  p <- panel f []
+wxMatch h isGuest chan = runCont (basicFrame frameConfig chan) $ setupFrame h isGuest
+
+
+frameConfig :: FrameConfig
+frameConfig = FrameConfig {
+  fCreate = frameFixed,
+  fTitle = "Create a match",
+  hasStatusField = False
+}
+
+
+setupFrame :: Handle -> Bool -> (Panel (), StatusField, FrameActions) -> IO ()
+setupFrame h isGuest (p, _, frame') = do
   match <- matchInputs p isGuest
   set (category match) [on select ::= onSelectGameTypeCategory (board match)]
 
-  b_ok  <- button p [text := "Match", on command := toString match >>= hPutStrLn h >> close f ]
-  b_can <- button p [text := "Cancel", on command := close f]
+  b_ok  <- button p [text := "Match", on command := toString match >>= hPutStrLn h >> closeFrame frame' ]
+  b_can <- button p [text := "Cancel", on command := closeFrame frame']
 
-  set f [ defaultButton := b_ok
-        , layout := container p $ margin 10 $ column 10 [
+  frame' `setDefaultButton` b_ok
+  set p [ layout := margin 10 $ column 10 [
                boxed "Game Type" (grid 15 15 [
                    [label "Category: ", hfill $ widget $ category match]
                  , [label "Board:" , hfill $ widget $ board match ]])
@@ -47,7 +58,6 @@ wxMatch h isGuest chan = do
               ])
             , floatBottomRight $ row 5 [widget b_can, widget b_ok]]
         ]
-  registerWxCloseEventListener f chan
 
 
 matchInputs :: Panel () -> Bool -> IO WxMatch

src/Macbeth/Wx/Seek.hs

@@ -10,6 +10,7 @@ import Macbeth.Wx.GameType
 import Macbeth.Wx.Utils
 
 import Control.Concurrent.Chan
+import Control.Monad.Cont
 import Data.Map (keys)
 import Graphics.UI.WX hiding (color)
 import Safe
@@ -42,19 +43,28 @@ data SeekInfo = SeekInfo {
   , _ratingTo :: Int
 }
 
-
 wxSeek :: Handle -> Bool -> Chan FicsMessage -> IO ()
-wxSeek h isGuest chan = do
-  f <- frameFixed [ text := "Seek a match" ]
-  p <- panel f []
+wxSeek h isGuest chan = runCont (basicFrame frameConfig chan) $ setupFrame h isGuest
+
+
+frameConfig :: FrameConfig
+frameConfig = FrameConfig {
+  fCreate = frameFixed,
+  fTitle = "Seek a match",
+  hasStatusField = False
+}
+
+
+setupFrame :: Handle -> Bool -> (Panel (), StatusField, FrameActions) -> IO ()
+setupFrame h isGuest (p, _, frame') = do
   match <- matchInputs p isGuest
   set (category match) [on select ::= onSelectGameTypeCategory (board match)]
 
-  b_ok  <- button p [text := "Create", on command := readSeek match >>= hPutStrLn h . ("4 seek " ++) . toString >> close f ]
-  b_can <- button p [text := "Cancel", on command := close f]
+  b_ok  <- button p [text := "Create", on command := readSeek match >>= hPutStrLn h . ("4 seek " ++) . toString >> closeFrame frame' ]
+  b_can <- button p [text := "Cancel", on command := closeFrame frame']
 
-  set f [ defaultButton := b_ok
-        , layout := container p $ margin 10 $ column 15 [
+  frame' `setDefaultButton` b_ok
+  set p [ layout := container p $ margin 10 $ column 15 [
             boxed "Game Type" (grid 15 15 [
               [label "Category: ", hfill $ widget $ category match, label "Board:", hfill $ widget $ board match ]
             ]),
@@ -66,7 +76,6 @@ wxSeek h isGuest chan = do
               ])
             , floatBottomRight $ row 5 [widget b_can, widget b_ok]]
         ]
-  registerWxCloseEventListener f chan
 
 
 -- seek [time inc] [rated|unrated] [white|black] [crazyhouse] [suicide]

src/Macbeth/Wx/Utils.hs

@@ -1,6 +1,9 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, MultiWayIf #-}
 
 module Macbeth.Wx.Utils (
+  FrameConfig(..),
+  FrameActions(..),
+  basicFrame,
   eventLoop,
   registerWxCloseEventListener,
   registerWxCloseEventListenerWithThreadId,
@@ -15,9 +18,42 @@ module Macbeth.Wx.Utils (
 import Macbeth.Fics.FicsMessage
 import Macbeth.Fics.Api.Api
 
+import Control.Monad.Cont
 import Control.Concurrent
-import Graphics.UI.WX
-import Graphics.UI.WXCore
+import Graphics.UI.WX hiding (when)
+import Graphics.UI.WXCore hiding (when)
+
+
+data FrameConfig = FrameConfig {
+    fCreate :: [Prop (Frame ())] -> IO (Frame ())
+  , fTitle :: String
+  , hasStatusField :: Bool
+}
+
+data FrameActions = FrameActions {
+  closeFrame :: IO (),
+  setDefaultButton :: Button () -> IO ()
+}
+
+basicFrame :: FrameConfig -> Chan FicsMessage -> Cont (IO ()) (Panel (), StatusField, FrameActions)
+basicFrame config chan = cont $ \callback -> do
+  f <- fCreate config [text := fTitle config]
+  p <- panel f []
+  status <- statusField []
+
+  _ <- registerWxCloseEventListener f chan
+
+  windowOnKeyDown p (\evt -> if
+    | onlyEsc evt -> close f
+    | keyWithMod evt 'W' justControl -> close f
+    | otherwise -> return ())
+
+  callback (
+    p,
+    status,
+    FrameActions (close f) (\btn -> set f [ defaultButton := btn]))
+  when (hasStatusField config) $ set f [ statusBar := [status] ]
+  set f [ layout := fill $ widget p ]
 
 
 eventLoop :: Int -> Chan FicsMessage -> MVar FicsMessage -> Frame () -> IO ()
@@ -61,6 +97,10 @@ onlyKey :: EventKey -> Char -> Bool
 onlyKey evt c = (keyKey evt == KeyChar c) && isNoneDown (keyModifiers evt)
 
 
+onlyEsc :: EventKey -> Bool
+onlyEsc evt = (keyKey evt == KeyEscape) && isNoneDown (keyModifiers evt)
+
+
 keyWithMod :: EventKey -> Char -> Modifiers -> Bool
 keyWithMod evt c modifier = (keyKey evt == KeyChar c) && (keyModifiers evt == modifier)