From 9f8d54bce82fb61c428996a9367ec1579410ff32 Mon Sep 17 00:00:00 2001
From: tv <tv@krebsco.de>
Date: Tue, 7 Feb 2023 04:10:06 +0100
Subject: move switchToDesktop to Graphics.X11.EWMH

---
 lib/Graphics/X11/EWMH.hs | 15 +++++++++++++--
 src/desktops.hs          | 13 +++++++++++--
 src/pager.hs             | 34 +++++++++++++++++-----------------
 3 files changed, 41 insertions(+), 21 deletions(-)

diff --git a/lib/Graphics/X11/EWMH.hs b/lib/Graphics/X11/EWMH.hs
index a44f5f7..856cfdb 100644
--- a/lib/Graphics/X11/EWMH.hs
+++ b/lib/Graphics/X11/EWMH.hs
@@ -8,10 +8,11 @@ import Control.Applicative ((<|>))
 import Data.List.Extra (split)
 import Foreign.C.Types (CLong)
 import Graphics.X11.EWMH.Atom
-import Graphics.X11.Types (Window)
+import Graphics.X11.Types (Window, clientMessage, substructureNotifyMask)
 import Graphics.X11.Xlib.Atom.Extra
+import Graphics.X11.Xlib.Event (allocaXEvent, sendEvent)
 import Graphics.X11.Xlib.Display (defaultRootWindow)
-import Graphics.X11.Xlib.Extras (changeProperty8, getWindowProperty32, propModeReplace)
+import Graphics.X11.Xlib.Extras (changeProperty8, getWindowProperty32, propModeReplace, setClientMessageEvent', setEventType)
 import Graphics.X11.Xlib.Extras.Extra (getWindowPropertyString)
 import Graphics.X11.Xlib.Types (Display)
 
@@ -55,3 +56,13 @@ setDesktopNames names dpy = do
     a = _NET_DESKTOP_NAMES
     t = uTF8_STRING
     r = defaultRootWindow dpy
+
+switchToDesktop :: Display -> CLong -> IO ()
+switchToDesktop dpy s =
+    allocaXEvent $ \e -> do
+      setEventType e clientMessage
+      setClientMessageEvent' e w _NET_CURRENT_DESKTOP 32 [fromIntegral s,0,0,0,0]
+      sendEvent dpy w False mask e
+  where
+    w = defaultRootWindow dpy
+    mask = substructureNotifyMask
diff --git a/src/desktops.hs b/src/desktops.hs
index fd5f99d..9b64e2d 100644
--- a/src/desktops.hs
+++ b/src/desktops.hs
@@ -1,15 +1,16 @@
 {-# LANGUAGE LambdaCase #-}
 module Main (main) where
 
+import Data.List (elemIndex)
 import Data.Map (Map)
 import Data.Maybe (fromMaybe)
-import Graphics.X11.EWMH (getCurrentDesktop, getDesktopNames, setDesktopNames)
+import Graphics.X11.EWMH (getCurrentDesktop, getDesktopNames, setDesktopNames, switchToDesktop)
 import Graphics.X11.Extra (withDefaultDisplay)
+import System.Environment (getArgs)
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy.Char8 as LBS8
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
-import System.Environment (getArgs)
 
 
 main :: IO ()
@@ -28,6 +29,7 @@ main =
             (x:y:xs) -> (x,y) : pairUp xs
             _ -> []
       "set" : names -> setWorkspaces names
+      "switch" : name : [] -> switchToWorkspace name
       x -> error $ "bad command: " <> show x
 
 getWorkspaces :: IO ()
@@ -68,3 +70,10 @@ renameWorkspaces renames = do
 
 setWorkspaces :: [String] -> IO ()
 setWorkspaces = withDefaultDisplay . setDesktopNames
+
+switchToWorkspace :: String -> IO ()
+switchToWorkspace name =
+    withDefaultDisplay $ \dpy -> do
+      names <- fromMaybe [] <$> getDesktopNames dpy
+      let Just i = name `elemIndex` names
+      switchToDesktop dpy (fromIntegral i)
diff --git a/src/pager.hs b/src/pager.hs
index 41c6eec..f5c7e0d 100644
--- a/src/pager.hs
+++ b/src/pager.hs
@@ -201,43 +201,43 @@ main = do
 
             return result
 
+    -- DEBUG: hPutStrLn hderp "XXX 5" >> hFlush hderp
 
     case snd result of
       FocusWorkspace name -> do
+          --wmpost (manager (fst result)) ("/workspace/" <> Text.unpack name <> "/view") ()
           case command (fst result) of
+            --ViewWorkspace ->
+            --  wmpost manager ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ())
             ViewWorkspace -> do
+              -- XXX [xmonad-http] wmpost manager ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ())
               X11.withDefaultDisplay $ \d -> do
                 let Just s = name `List.elemIndex` map workspace_name workspaces
-                switchDesktop d (fromIntegral s)
+                X11.switchToDesktop d (fromIntegral s)
+
+            ShiftWindowToWorkspace window -> do
+              -- XXX [xmonad-http] wmpost manager ("/workspace/" <> Text.unpack name <> "/shift/" <> Text.unpack wid) () :: IO (Maybe ())
 
-            ShiftWindowToWorkspace _ -> do
               X11.withDefaultDisplay $ \d ->
                 let
                   Just s = name `List.elemIndex` map workspace_name workspaces
                 in
-                windowToDesktop d activeWindow (fromIntegral s)
+                --debug (name, s, activeWindow, window) >>
+                --windowToDesktop d activeWindow (fromIntegral s)
+                windowToDesktop d (fromIntegral window) (fromIntegral s)
 
-            ShiftWindowToAndViewWorkspace _ -> do
+            ShiftWindowToAndViewWorkspace window -> do
+              -- XXX [xmonad-http] wmpost manager ("/workspace/" <> Text.unpack name <> "/shiftview/" <> show wid) () :: IO (Maybe ())
               X11.withDefaultDisplay $ \d -> do
                 let Just s = name `List.elemIndex` map workspace_name workspaces
-                windowToDesktop d activeWindow (fromIntegral s)
-                switchDesktop d (fromIntegral s)
+                --windowToDesktop d activeWindow (fromIntegral s)
+                windowToDesktop d (fromIntegral window) (fromIntegral s)
+                X11.switchToDesktop d (fromIntegral s)
 
       _ ->
         return ()
 
 
-switchDesktop :: X11.Display -> CLong -> IO ()
-switchDesktop d s =
-  X11.allocaXEvent $ \e -> do
-    X11.setEventType e X11.clientMessage
-    X11.setClientMessageEvent' e w X11._NET_CURRENT_DESKTOP 32 [fromIntegral s,0,0,0,0]
-    X11.sendEvent d w False mask e
-  where
-    w = X11.defaultRootWindow d
-    mask = X11.structureNotifyMask
-
-
 windowToDesktop :: X11.Display -> X11.Window -> CLong -> IO ()
 windowToDesktop d w s =
   X11.allocaXEvent $ \e -> do
-- 
cgit v1.2.3