path: root/src/Rahm/Desktop/Common.hs

module Rahm.Desktop.Common
  ( focusLocation,
    masterWindow,
    windowsInWorkspace,
    duplWindow,
    pointerWorkspace,
    getString,
    setBorderWidth,
    askWindowId,
    windowJump,
    withBorderWidth,
    getCurrentScreen,
    gotoWorkspace,
    moveLocationToWorkspace,
    getCurrentWorkspace,
    getCurrentLocation,
    runMaybeT_,
    click,
    pointerLocation,
    pointerWindow,
    getDisplayAndRoot,
    Location (..),
    Xish(..),
  )
where

import Control.Applicative ((<*))
import Control.Exception (SomeException (SomeException), catch)
import Control.Monad (forM_, void, when)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT, throwE)
import Control.Monad.Trans.Identity (IdentityT (..))
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Char (toLower)
import Data.Either (either)
import Data.List (concatMap, isInfixOf, map, (++))
import Data.List.Safe (head, tail)
import Data.List.Split (splitOn)
import qualified Data.Map as Map (fromListWith)
import Data.Maybe (Maybe (..), maybe)
import Data.Void (Void (..), absurd)
import Data.Word (Word32)
import Rahm.Desktop.DMenu (runDMenuPromptWithMap, runDMenuPromptWithMapMulti)
import Rahm.Desktop.Logger
import qualified Rahm.Desktop.StackSet as S
  ( Screen (Screen, workspace),
    StackSet (StackSet, current),
    Workspace (Workspace, stack, tag),
    allWindows,
    focusWindow,
    greedyView,
    integrate',
    peek,
    shiftWin,
    workspaces,
  )
import Text.Printf (printf)
import XMonad
  ( ScreenId,
    Window,
    WorkspaceId,
    X,
    XConf (config, display),
    XConfig (focusedBorderColor, normalBorderColor),
    appName,
    asks,
    focus,
    io,
    liftX,
    refresh,
    runQuery,
    setWindowBorderWidth,
    setWindowBorderWithFallback,
    stringProperty,
    title,
    windows,
    withFocused,
    withWindowSet,
  )
import qualified XMonad as X
import qualified XMonad.Hooks.ManageHelpers as X
import XMonad.Prompt (XPrompt (commandToComplete, showXPrompt))
import qualified XMonad.Util.Run as X
import XMonad.Util.XUtils (pixelToString, stringToPixel)
import Prelude hiding (head, tail)

-- A location is a workspace and maybe a window with that workspace.
data Location = Location
  { locationWorkspace :: WorkspaceId,
    locationWindow :: Maybe Window
  }
  deriving (Read, Show, Eq, Ord)

focusLocation :: Location -> X ()
focusLocation (Location ws mWin) =
  windows $ maybe id S.focusWindow mWin . S.greedyView ws

masterWindow :: MaybeT X Window
masterWindow = MaybeT $
  withWindowSet $ \ss ->
    let windows = (S.integrate' . S.stack . S.workspace . S.current) ss
     in case windows of
          (a : _) -> return $ Just a
          _ -> return Nothing

windowsInWorkspace :: WorkspaceId -> X [Location]
windowsInWorkspace wid =
  withWindowSet $
    return
      . concatMap
        ( \ws ->
            if S.tag ws == wid
              then map (Location wid . Just) $ S.integrate' (S.stack ws)
              else []
        )
      . S.workspaces

data WinPrompt = WinPrompt

instance XPrompt WinPrompt where
  showXPrompt _ = "[Window] "
  commandToComplete _ = id

getString :: Window -> X String
getString = runQuery $ do
  t <- title
  a <- appName
  return $
    if map toLower a `isInfixOf` map toLower t
      then t
      else printf "%s - %s" t a

askWindowId :: X [Window]
askWindowId = do
  windowTitlesToWinId <- withWindowSet $ \ss ->
    Map.fromListWith (++) <$> mapM (\wid -> (,) <$> getString wid <*> return [wid]) (S.allWindows ss)

  concat <$> runDMenuPromptWithMapMulti "Window" (Just "#f542f5") windowTitlesToWinId

windowJump :: X ()
windowJump = mapM_ focus . headM =<< askWindowId
  where
    headM :: [a] -> Maybe a
    headM = head

setBorderWidth :: Int -> [Window] -> X ()
setBorderWidth width wins = do
  d <- asks display
  forM_ wins $ \window ->
    io $ setWindowBorderWidth d window $ fromIntegral width

withBorderWidth :: Int -> [Window] -> X a -> X a
withBorderWidth width ws fn = do
  d <- asks display

  forM_ ws $ \window ->
    io $ setWindowBorderWidth d window $ fromIntegral width

  ret <- fn

  forM_ ws $ \window ->
    io $ setWindowBorderWidth d window 2

  refresh

  return ret

gotoWorkspace :: WorkspaceId -> X ()
gotoWorkspace wid = do
  logs Debug "GotoWorkspace %s" wid
  windows $ S.greedyView wid

moveLocationToWorkspace :: Location -> WorkspaceId -> X ()
moveLocationToWorkspace (Location _ (Just win)) wid =
  windows $ S.shiftWin wid win
moveLocationToWorkspace _ _ = return ()

getCurrentWorkspace :: X WorkspaceId
getCurrentWorkspace = withWindowSet $
  \(S.StackSet (S.Screen (S.Workspace t _ _) _ _) _ _ _) -> do
    return t

getCurrentScreen :: X ScreenId
getCurrentScreen = withWindowSet $
  \(S.StackSet (S.Screen _ sid _) _ _ _) -> return sid

getCurrentLocation :: X Location
getCurrentLocation = do
  ws <- getCurrentWorkspace
  win <- withWindowSet (return . S.peek)
  return (Location ws win)

runMaybeT_ :: (Monad m) => MaybeT m a -> m ()
runMaybeT_ = void . runMaybeT

click :: X ()
click = do
  (dpy, root) <- asks $ (,) <$> display <*> X.theRoot
  (_, _, window, _, _, _, _, _) <- io $ X.queryPointer dpy root
  focus window

getDisplayAndRoot :: X (X.Display, X.Window)
getDisplayAndRoot = X.asks $ (,) <$> X.display <*> X.theRoot

pointerLocation :: (Integral a, Integral b) => X (a, b)
pointerLocation = do
  (dpy, root) <- getDisplayAndRoot
  (_, _, _, fromIntegral -> x, fromIntegral -> y, _, _, _) <-
    io $ X.queryPointer dpy root
  return (x, y)

pointerWindow :: X X.Window
pointerWindow = do
  (dpy, root) <- getDisplayAndRoot
  (_, _, w, _, _, _, _, _) <-
    io $ X.queryPointer dpy root
  return w

pointerWorkspace :: X (Maybe WorkspaceId)
pointerWorkspace = runMaybeT $ do
  (x, y) <- lift pointerLocation
  (S.Screen (S.tag -> ws1) _ _) <- MaybeT $ X.pointScreen x y
  return ws1

-- Creates a duplicate process of a window by running the cmdline
-- that created it.
duplWindow :: Window -> X ()
duplWindow = runQuery $ do
  pid' <- X.pid
  liftX $ logs Info "Duplicating for pid %s" (show pid')
  forM_ pid' $ \pid -> do
    cmd <-
      liftX $
        io $
          catch
            (fmap (Right . splitOn "\0") $ readFile $ "/proc/" <> show pid <> "/cmdline")
            ( \e ->
                let ex = e :: SomeException
                 in return $ Left (printf "Could not read cmdline file: %s" (show ex))
            )

    liftX $
      case cmd of
        Right c -> do
          logs Info "executing cmdline: %s\n" (show c)
          case c of
            (a : (init -> as)) -> X.safeSpawn a as
            _ -> return ()
        Left err -> logs Info "%s" (err :: String)

class (Monad m) => Xish m where
  liftFromX :: X a -> m a

instance Xish X where
  liftFromX = id