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

module Rahm.Desktop.Common
  ( focusLocation,
    masterWindow,
    windowsInWorkspace,
    duplWindow,
    pointerWorkspace,
    getString,
    askWindowId,
    windowJump,
    withBorderColor,
    withBorderColorE,
    withBorderColorM,
    withBorderWidth,
    getCurrentScreen,
    gotoWorkspace,
    moveLocationToWorkspace,
    getCurrentWorkspace,
    getCurrentLocation,
    runMaybeT_,
    setBorderColor,
    click,
    pointerLocation,
    pointerWindow,
    getDisplayAndRoot,
    Location (..),
  )
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, head, isInfixOf, map, (++))
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)
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)

-- 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 (Maybe [Window])
askWindowId = do
  windowTitlesToWinId <- withWindowSet $ \ss ->
    Map.fromListWith (++) <$> mapM (\wid -> (,) <$> getString wid <*> return [wid]) (S.allWindows ss)

  runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId

windowJump :: X ()
windowJump = mapM_ (focus . head) =<< askWindowId

-- Have to add a definition because Stack uses an ancient version of
-- transformers for some reason.
myFinallyE :: (Monad m) => ExceptT e m a -> ExceptT e m () -> ExceptT e m a
myFinallyE m closer = catchE (m <* closer) (\e -> closer >> throwE e)

-- Temporarily set the border color of the given windows.
withBorderColorE :: String -> [Window] -> ExceptT e X a -> ExceptT e X a
withBorderColorE color wins fn = do
  cleanup <- lift (setBorderColor color wins)
  myFinallyE fn (lift cleanup)

-- Set the border color for the given windows. This function returns another
-- function that should be used to clean up the border changes.
setBorderColor :: String -> [Window] -> X (X ())
setBorderColor color wins = do
  d <- asks display
  (px, oPx, fPx) <-
    (,,)
      <$> stringToPixel d color
      <*> (stringToPixel d =<< asks (normalBorderColor . config))
      <*> (stringToPixel d =<< asks (focusedBorderColor . config))

  (colorName, oColorName, fColorName) <-
    (,,)
      <$> io (pixelToString d px)
      <*> io (pixelToString d oPx)
      <*> io (pixelToString d fPx)

  forM_ wins $ \w ->
    setWindowBorderWithFallback d w colorName px

  return $ do
    forM_ wins $ \w ->
      setWindowBorderWithFallback d w oColorName oPx
    withFocused $ \fw ->
      when (fw `elem` wins) $
        setWindowBorderWithFallback d fw fColorName fPx

withBorderColorM :: String -> [Window] -> MaybeT X a -> MaybeT X a
withBorderColorM s ws fn = toMaybeT $ withBorderColorE s ws (toExceptT fn)
  where
    toExceptT (MaybeT fn) = ExceptT $ maybe (Left ()) Right <$> fn
    toMaybeT (ExceptT fn) = MaybeT $ either (const Nothing) Just <$> fn

withBorderColor :: String -> [Window] -> X a -> X a
withBorderColor s ws fn =
  either absurd id <$> runExceptT (withBorderColorE s ws (lift fn))

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)