diff --git a/app/current-output.hs b/app/current-output.hs new file mode 100644 index 0000000..13c9b26 --- /dev/null +++ b/app/current-output.hs @@ -0,0 +1,93 @@ +module Main (main) where + +-------------------------------------------------------------------------------- +-- | Return current xrandr output name +-- +-- Since this seems random, the reason for this is that I want rofi to appear +-- over the current xmonad workspace, and rofi has no concept of what an +-- xmonad workspace is (not that it is supposed to, xmonad is weird...). Rofi +-- accepts the name of an xrandr output onto which it should appear, so this +-- script provides a way to determine which xmonad workspace is in focus and +-- provide the name of the output displaying said workspace. +-- +-- Assumptions: xmonad sets the _NET_DESKTOP_VIEWPORT atom with the positions of +-- the active workspace (actually an array of the positions of all workspaces +-- but the rest don't matter if I only care about the active one). This is not +-- default behavior and not in any contrib modules (yet) so I added this myself +-- using a custom loghook. +-- +-- Steps: +-- 1) Get _NET_CURRENT_DESKTOP to find index of active workspace +-- 2) Use index from (1) and to get the position of the active workspace from +-- _NET_DESKTOP_VIEWPORT +-- 3) Find the name of the xrandr output whose position matches that from (2) + +import Data.Maybe (catMaybes, maybe) + +import Graphics.X11.Types +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xrandr + +import System.Exit + +main :: IO () +main = getMonitorName >>= maybe exitFailure (\n -> putStrLn n >> exitSuccess) + +data Coord = Coord Int Int + deriving Eq + +getMonitorName :: IO (Maybe String) +getMonitorName = do + dpy <- openDisplay "" + root <- rootWindow dpy $ defaultScreen dpy + index <- getCurrentDesktopIndex dpy root + viewports <- getDesktopViewports dpy root + outputs <- getOutputs dpy root + return $ flip lookup outputs =<< (viewports !!?) =<< index + +getCurrentDesktopIndex :: Display -> Window -> IO (Maybe Int) +getCurrentDesktopIndex dpy root = + (!!? 0) <$> getAtom32 dpy root "_NET_CURRENT_DESKTOP" + +getDesktopViewports :: Display -> Window -> IO [Coord] +getDesktopViewports dpy root = + pairs <$> getAtom32 dpy root "_NET_DESKTOP_VIEWPORT" + where + pairs = reverse . pairs' [] + pairs' acc [] = acc + pairs' acc [_] = acc + pairs' acc (x1:x2:xs) = pairs' (Coord x1 x2 : acc) xs + +getOutputs :: Display -> Window -> IO [(Coord, String)] +getOutputs dpy root = xrrGetScreenResourcesCurrent dpy root >>= + maybe (return []) resourcesToCells + where + resourcesToCells r = catMaybes <$> mapM (outputToCell r) (xrr_sr_outputs r) + outputToCell r o = xrrGetOutputInfo dpy r o >>= infoToCell r + -- connection: 0 == connected, 1 == disconnected + infoToCell r (Just XRROutputInfo { xrr_oi_connection = 0 + , xrr_oi_name = n + , xrr_oi_crtc = c + }) = do + cinfo <- xrrGetCrtcInfo dpy r c + return $ fmap (\i -> (toCoord i, n)) cinfo + infoToCell _ _ = return Nothing + toCoord c = Coord (fromIntegral $ xrr_ci_x c) (fromIntegral $ xrr_ci_y c) + +infix 9 !!? +(!!?) :: [a] -> Int -> Maybe a +(!!?) xs i + | i < 0 = Nothing + | otherwise = go i xs + where + go :: Int -> [a] -> Maybe a + go 0 (x:_) = Just x + go j (_:ys) = go (j - 1) ys + go _ [] = Nothing + +getAtom32 :: Display -> Window -> String -> IO [Int] +getAtom32 dpy root str = do + a <- internAtom dpy str False + p <- getWindowProperty32 dpy a root + return $ maybe [] (fmap fromIntegral) p diff --git a/package.yaml b/package.yaml index 739527a..4318d21 100644 --- a/package.yaml +++ b/package.yaml @@ -38,6 +38,7 @@ dependencies: - unliftio-core >= 0.1.2.0 - word-wrap >= 0.4.1 - text >= 1.2.3.1 +- X11 >= 1.9.1 library: source-dirs: lib/ @@ -67,3 +68,12 @@ executables: - -threaded dependencies: - rofi-extras + current-output: + main: current-output.hs + source-dirs: app + ghc-options: + - -Wall + - -Werror + - -threaded + dependencies: + - rofi-extras