refactor, trying to seperate out IO from W stuff, in order to QC the handler at some point

darcs-hash:20070310012940-9c5c1-2118696702dac70f922b5ba781a3775598b955cd.gz

2 files changed, 50 insertions, 38 deletions

diff --git a/Main.hs b/Main.hs
index 1f4ec0e..c736ba1 100644
--- a/Main.hs
+++ b/Main.hs
@@ -59,49 +59,56 @@ keys = M.fromList $
 main :: IO ()
 main = do
     dpy <- openDisplay ""
-    let dflt      = defaultScreen dpy
-        initState = WState
+    let dflt = defaultScreen dpy
+        st   = WState
             { display      = dpy
             , screenWidth  = displayWidth  dpy dflt
             , screenHeight = displayHeight dpy dflt
             , workspace    = W.empty workspaces
             }
 
-    allocaXEvent $ \ev ->
-     runW initState $ do
-        r <- io $ rootWindow dpy dflt
-        io $ sync dpy False
-        io $ selectInput dpy r $  substructureRedirectMask
-                              .|. substructureNotifyMask
-                              .|. enterWindowMask
-                              .|. leaveWindowMask
+    -- setup initial X environment
+    rootw <- rootWindow dpy dflt
+    sync dpy False
+    selectInput dpy rootw $  substructureRedirectMask
+                         .|. substructureNotifyMask
+                         .|. enterWindowMask
+                         .|. leaveWindowMask
+    grabKeys dpy rootw
+    sync dpy False
+
+    ws   <- scan dpy rootw
+    allocaXEvent $ \e ->
+        runW st $ do
+            mapM_ manage ws
+            forever $ handle =<< xevent dpy e
+      where
+        xevent d e = io (nextEvent d e >> getEvent e)
+        forever a = a >> forever a
 
-        grabKeys dpy r
-
-        -- scan for initial windows
-        (_, _, ws) <- io $ queryTree dpy r
-        forM_ ws $ \w -> do
-            wa <- io $ getWindowAttributes dpy w
-            when (not (waOverrideRedirect wa) && waMapState wa == waIsViewable)
-                    (manage w)
-
-        io $ sync dpy False
-        forever $ handle =<< io (nextEvent dpy ev >> getEvent ev)
-
-    return ()
+-- ---------------------------------------------------------------------
+-- IO stuff. Doesn't require any W state
+-- Most of these things run only on startup (bar grabkeys)
+
+-- | scan for any initial windows to manage
+scan :: Display -> Window -> IO [Window]
+scan dpy rootw = do
+    (_, _, ws) <- queryTree dpy rootw
+    filterM ok ws
   where
-    forever a = a >> forever a
+    ok w = do wa <- getWindowAttributes dpy w
+              return $ not (waOverrideRedirect wa)
+                     && waMapState wa == waIsViewable
 
 -- | Grab the keys back
-grabKeys :: Display -> Window -> W ()
-grabKeys dpy r = do
-    io $ ungrabKey dpy '\0' {-AnyKey-} anyModifier r
-    forM_ (M.keys keys) $ \(mask,s) -> io $ do
-        kc <- keysymToKeycode dpy s
-        let grab m = grabKey dpy kc m r True grabModeAsync grabModeAsync
-        grab mask
-        grab (mask .|. lockMask)
-        -- no numlock
+grabKeys :: Display -> Window -> IO ()
+grabKeys dpy rootw = do
+    ungrabKey dpy '\0' {-AnyKey-} anyModifier rootw
+    forM_ (M.keys keys) $ \(mask,sym) -> do
+         kc <- keysymToKeycode dpy sym
+         mapM_ (grab kc) [mask, mask .|. lockMask] -- note: no numlock
+  where
+    grab kc m = grabKey dpy kc m rootw True grabModeAsync grabModeAsync
 
 -- ---------------------------------------------------------------------
 -- Event handler
@@ -120,6 +127,13 @@ grabKeys dpy r = do
 -- on LeaveNotify, we set it back to root.
 --
 -- Needs XCrossing support
+--
+-- Todo: seperate IO from W monad stuff. We want to be able to test the
+-- handler, and client functions, with dummy X interface ops, in QuickCheck
+--
+-- Will require an abstract interpreter from Event -> W Action, which
+-- modifies the internal W state, and then produces an IO action to
+-- evaluate.
 -- 
 handle :: Event -> W ()
 
@@ -136,7 +150,7 @@ handle (UnmapEvent         {window = w}) = unmanage w
 handle e@(MappingNotifyEvent {window = w}) = do
     let m = (request e, first_keycode e, count e)
     io $ refreshKeyboardMapping m
-    when (request e == mappingKeyboard) $ withDisplay $ flip grabKeys w
+    when (request e == mappingKeyboard) $ withDisplay $ io . flip grabKeys w
 
 handle (KeyEvent {event_type = t, state = m, keycode = code})
     | t == keyPress = withDisplay $ \dpy -> do
@@ -214,8 +228,6 @@ manage w = do
         -- setInputFocus d w revertToPointerRoot 0 -- CurrentTime
     windows $ W.push w
 
-
-
 -- | unmanage. A window no longer exists, remove it from the window
 -- list, on whatever workspace it is.
 unmanage :: Window -> W ()
diff --git a/WMonad.hs b/WMonad.hs
index af18901..4e622c5 100644
--- a/WMonad.hs
+++ b/WMonad.hs
@@ -43,8 +43,8 @@ newtype W a = W (StateT WState IO a)
 
 -- | Run the W monad, given a chunk of W monad code, and an initial state
 -- Return the result, and final state
-runW :: WState -> W a -> IO (a, WState)
-runW st (W a) = runStateT a st
+runW :: WState -> W a -> IO ()
+runW st (W a) = runStateT a st >> return ()
 
 -- | Run a monad action with the current display settings
 withDisplay :: (Display -> W ()) -> W ()