From 1b02b3235fd054f3803492ea820f90f07b18eb13 Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Thu, 19 Dec 2024 10:34:23 +0700
Subject: [PATCH] Add `driver/XMonad.hs`

---
 driver/XMonad.hs | 78 ++++++++++++++++++++++++++++++++++++++++++++++++
 driver/sensei.hs |  5 +++-
 sensei.cabal     |  3 ++
 3 files changed, 85 insertions(+), 1 deletion(-)
 create mode 100644 driver/XMonad.hs

diff --git a/driver/XMonad.hs b/driver/XMonad.hs
new file mode 100644
index 00000000..3ff5b9f1
--- /dev/null
+++ b/driver/XMonad.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE NoOverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
+module XMonad where
+
+-- import Control.Exception (IOException, try)
+import System.Process
+import System.Posix.Process (getProcessID)
+-- import Data.Maybe (listToMaybe)
+import Data.Functor
+import System.Exit
+import Data.List
+
+import Imports
+
+newtype PID = PID String
+newtype XWindowId = XWindowId String
+newtype Tag = Tag String
+
+instance IsString Tag where
+  fromString = Tag
+
+-- Get the parent PID of a process
+getParentPid :: PID -> IO (Maybe PID)
+getParentPid (PID pid) = readProcessWithExitCode "ps" ["-o", "ppid=", "-p", pid] "" <&> \ case
+  (_, result, _) -> case strip result of
+    "" -> Nothing
+    ppid -> Just (PID ppid)
+
+getWindowIdForPid :: PID -> IO (Maybe XWindowId)
+getWindowIdForPid (PID pid) = do
+  windowIds <- filter (isPrefixOf "0x") . words <$> readProcess "xprop" ["-root", "_NET_CLIENT_LIST"] ""
+  findWindow windowIds
+  where
+    findWindow :: [String] -> IO (Maybe XWindowId)
+    findWindow = \ case
+      [] -> return Nothing
+      wid : rest -> do
+        (_, wmPidOutput, _) <- readProcessWithExitCode "xprop" ["-id", wid, "_NET_WM_PID"] ""
+        case reverse (words wmPidOutput) of
+          wmPid : _ | wmPid == pid -> return (Just $ XWindowId wid)
+          _ -> findWindow rest
+
+findAncestorWindowId :: PID -> IO (Maybe XWindowId)
+findAncestorWindowId pid = do
+  windowId <- getWindowIdForPid pid
+  case windowId of
+    Just wid -> return (Just wid)
+    Nothing -> do
+      parentPid <- getParentPid pid
+      case parentPid of
+        Just ppid -> findAncestorWindowId ppid
+        Nothing -> return Nothing
+
+addTag :: Tag -> XWindowId -> IO ()
+addTag (Tag name) (XWindowId wid) = do
+  result <- readProcess "xprop" ["-id", wid, "_XMONAD_TAGS"] ""
+  
+  let 
+    tags :: String
+    tags = if "not found" `elem` words result then "" else extractTags result
+    
+    newTags :: String
+    newTags = if null tags then name else tags <> " " <> name
+  
+  callProcess "xprop" ["-id", wid, "-f", "_XMONAD_TAGS", "8s", "-set", "_XMONAD_TAGS", newTags]
+  where
+    extractTags :: String -> String
+    extractTags = unwords . drop 1 . words . last . lines
+
+tagSelfWith :: Tag -> IO ()
+tagSelfWith name = do
+  pid <- PID . show <$> getProcessID
+  result <- findAncestorWindowId pid
+  case result of
+    Just wid -> addTag name wid
+    Nothing -> exitFailure
diff --git a/driver/sensei.hs b/driver/sensei.hs
index 25c55dea..fb418527 100644
--- a/driver/sensei.hs
+++ b/driver/sensei.hs
@@ -2,7 +2,10 @@ module Main (main) where
 
 import           System.Environment
 
+import qualified XMonad
 import           Run
 
 main :: IO ()
-main = getArgs >>= run
+main = do
+  XMonad.tagSelfWith "sensei"
+  getArgs >>= run
diff --git a/sensei.cabal b/sensei.cabal
index 6c69a9e6..2b803dc1 100644
--- a/sensei.cabal
+++ b/sensei.cabal
@@ -40,6 +40,7 @@ executable seito
       Session
       Trigger
       Util
+      XMonad
       Paths_sensei
   autogen-modules:
       Paths_sensei
@@ -103,6 +104,7 @@ executable sensei
       Session
       Trigger
       Util
+      XMonad
   hs-source-dirs:
       src
       driver
@@ -163,6 +165,7 @@ executable sensei-web
       Session
       Trigger
       Util
+      XMonad
   hs-source-dirs:
       src
       driver