ADD program to print the name of the currently focused output

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

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