From 63ee5288aea5972d2eb0021a797fc6ec770d6ee0 Mon Sep 17 00:00:00 2001 From: tv Date: Tue, 7 Feb 2023 03:47:08 +0100 Subject: add `desktops` utility --- pager.cabal | 14 +- src/desktops.hs | 70 ++++++ src/main.hs | 646 -------------------------------------------------------- src/pager.hs | 646 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 729 insertions(+), 647 deletions(-) create mode 100644 src/desktops.hs delete mode 100644 src/main.hs create mode 100644 src/pager.hs diff --git a/pager.cabal b/pager.cabal index d588963..ee8267e 100644 --- a/pager.cabal +++ b/pager.cabal @@ -16,8 +16,20 @@ source-repository this location: https://cgit.krebsco.de/pager tag: 1.0.0 +executable desktops + main-is: desktops.hs + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src + build-depends: base >= 4.13 && < 5 + , X11 + , aeson + , bytestring + , containers + , pager + executable pager - main-is: main.hs + main-is: pager.hs default-language: Haskell2010 ghc-options: -Wall -threaded -with-rtsopts=-N hs-source-dirs: src diff --git a/src/desktops.hs b/src/desktops.hs new file mode 100644 index 0000000..fd5f99d --- /dev/null +++ b/src/desktops.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE LambdaCase #-} +module Main (main) where + +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import Graphics.X11.EWMH (getCurrentDesktop, getDesktopNames, setDesktopNames) +import Graphics.X11.Extra (withDefaultDisplay) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import System.Environment (getArgs) + + +main :: IO () +main = + getArgs >>= \case + [] -> getWorkspaces + "get" : [] -> getWorkspaces + "add" : names -> addWorkspaces names + "remove" : names -> removeWorkspaces names + "rename" : name : [] -> renameCurrentWorkspace name + "rename" : args | not (null args) && length args `mod` 2 == 0 -> + renameWorkspaces renames + where + renames = Map.fromList (pairUp args) + pairUp = \case + (x:y:xs) -> (x,y) : pairUp xs + _ -> [] + "set" : names -> setWorkspaces names + x -> error $ "bad command: " <> show x + +getWorkspaces :: IO () +getWorkspaces = + LBS8.putStrLn =<< Aeson.encode <$> withDefaultDisplay getDesktopNames + +addWorkspaces :: [String] -> IO () +addWorkspaces names = + withDefaultDisplay $ \dpy -> do + names' <- + (<>names) . + fromMaybe [] <$> getDesktopNames dpy + setDesktopNames names' dpy + +removeWorkspaces :: [String] -> IO () +removeWorkspaces names = + withDefaultDisplay $ \dpy -> do + names' <- + filter (not . flip Set.member (Set.fromList names)) . + fromMaybe [] <$> getDesktopNames dpy + setDesktopNames names' dpy + +renameCurrentWorkspace :: String -> IO () +renameCurrentWorkspace name = + withDefaultDisplay $ \dpy -> do + i <- maybe 0 fromIntegral <$> getCurrentDesktop dpy + names <- fromMaybe [] <$> getDesktopNames dpy + let names' = take i names <> [name] <> drop (i + 1) names + setDesktopNames names' dpy + +renameWorkspaces :: Map String String-> IO () +renameWorkspaces renames = do + withDefaultDisplay $ \dpy -> do + names' <- + map (\name -> fromMaybe name (Map.lookup name renames)) . + fromMaybe [] <$> getDesktopNames dpy + setDesktopNames names' dpy + +setWorkspaces :: [String] -> IO () +setWorkspaces = withDefaultDisplay . setDesktopNames diff --git a/src/main.hs b/src/main.hs deleted file mode 100644 index 41c6eec..0000000 --- a/src/main.hs +++ /dev/null @@ -1,646 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -module Main (main) where - -import Blessings.Text (Blessings(Plain,SGR),pp) -import Control.Concurrent -import Control.Monad (forM) -import Control.Monad (forever) -import Data.Bits ((.|.),testBit) -import Data.Default (def) -import Data.Function ((&)) -import Data.List.Extra ((!!?)) -import Data.Maybe (catMaybes,fromMaybe) -import Data.Monoid.Extra (mintercalate) -import Data.Set (Set) -import Data.Text (Text) -import Foreign.C.Types (CLong) -import Much.Screen (Screen(Screen), withScreen) -import Pager.Types -import Scanner -import State (State(..)) -import System.Environment (getArgs) -import System.IO -import System.Posix.Signals (Handler(Catch), Signal, installHandler, sigINT) -import qualified Blessings.Internal as Blessings -import qualified Data.Char as Char -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Extra as Text -import qualified Data.Text.IO as Text -import qualified Data.Text.Read as Text -import qualified Graphics.X11 as X11 -import qualified Graphics.X11.EWMH as X11; -import qualified Graphics.X11.Extra as X11 -import qualified Graphics.X11.Xlib.Extras as X11 -import qualified Hack.Buffer as Buffer -import qualified Hack.Buffer.Extra as Buffer -import qualified Pager.Sixelerator as Pager -import qualified System.Console.Terminal.Size as Term - - -getGeometry :: X11.Display -> X11.Window -> IO Geometry -getGeometry d w = do - (_, x, y, width, height, _, _) <- X11.getGeometry d w - return Geometry - { geometry_x = fromIntegral x - , geometry_y = fromIntegral y - , geometry_width = fromIntegral width - , geometry_height = fromIntegral height - } - -getWorkspaces :: X11.Display -> Geometry -> Set X11.Window -> IO [Workspace] -getWorkspaces display screenGeometry focusWindows = do - let rootWindow = X11.defaultRootWindow display - - currentDesktop <- fromMaybe 0 <$> X11.getCurrentDesktop display - - workspaces <- do - names <- zip [0..] . fromMaybe [] <$> X11.getDesktopNames display - ws <- - forM names $ \(index, name) -> do - return Workspace - { workspace_geometry = screenGeometry - , workspace_focused = currentDesktop == index - , workspace_name = Text.pack name - , workspace_windows = [] - } - return $ Map.fromList $ zip [0..] ws - - clientList <- - maybe [] (map fromIntegral) <$> - X11.getWindowProperty32 display X11._NET_CLIENT_LIST rootWindow - - let - f w = do - title <- X11.getWindowTitle display w - desktop <- fromMaybe 0 <$> X11.getWindowDesktop display w - geometry <- getGeometry display w - - wm_hints <- X11.getWMHints display w - let urgent = testBit (X11.wmh_flags wm_hints) X11.urgencyHintBit - - let - window = - Window - { window_id = fromIntegral w - , window_title = Text.pack $ fromMaybe "" title - , window_geometry = geometry - , window_focused = Set.member w focusWindows - , window_urgent = urgent - } - - return ( window, desktop ) - - clientList' <- mapM f clientList - - return - $ map (\ws -> ws { workspace_windows = - uncurry (<>) $ - List.partition window_focused (workspace_windows ws) - }) - $ Map.elems - $ foldr - (\(w, i) -> - Map.adjust (\ws -> ws { workspace_windows = w : workspace_windows ws }) - i - ) - workspaces - clientList' - - -main :: IO () -main = do - args <- getArgs - let - ( commandFromArgs, focusWindows ) = - let readInt s = - case Text.decimal (Text.pack s) of - Right (i, "") -> - i - _ -> - (-1) - in - case args of - "shift" : focusWindows_ -> - ( ShiftWindowToWorkspace undefined, map readInt focusWindows_ ) - - "shiftview" : focusWindows_ -> - ( ShiftWindowToAndViewWorkspace undefined, map readInt focusWindows_ ) - - "view" : focusWindows_ -> - ( ViewWorkspace, map readInt focusWindows_ ) - - _ -> - error $ "bad arguments: " <> show args - - - Just activeWindow <- X11.withDefaultDisplay X11.getActiveWindow - - screenGeometry <- - X11.withDefaultDisplay $ \display -> do - let rootWindow = X11.defaultRootWindow display - getGeometry display rootWindow - - workspaces <- - X11.withDefaultDisplay $ \display -> do - getWorkspaces display screenGeometry (Set.fromList focusWindows) - - let screen0 = Screen False NoBuffering (BlockBuffering $ Just 4096) - [ 1000 -- X & Y on button press and release - , 1005 -- UTF-8 mouse mode - , 1047 -- use alternate screen buffer - , 80 -- enable sixel scrolling - ] - [ 25 -- hide cursor - ] - result <- do - withFile "/dev/tty" ReadWriteMode $ \i -> - withFile "/dev/tty" WriteMode $ \o -> - withScreen i o screen0 $ \_ -> do - (putEvent, getEvent) <- do - v <- newEmptyMVar - return (putMVar v, takeMVar v) - - let q1 = - updateFoundWorkspaces $ def - { command = commandFromArgs - , screenHeight = geometry_height screenGeometry - , screenWidth = geometry_width screenGeometry - , termBorder = 2 - , workspaces = - let - f workspace@Workspace{workspace_name} = ( workspace_name, workspace ) - in - Map.fromList (map f workspaces) - } - signalHandlers = - [ (sigINT, putEvent EShutdown) - , (28, winchHandler i putEvent) - ] - - installHandlers signalHandlers - - winchHandler i putEvent - - threadIds <- mapM forkIO - [ - forever $ - scan i >>= putEvent . EScan - ] - - result <- run o getEvent q1 - - mapM_ killThread threadIds - - return result - - - case snd result of - FocusWorkspace name -> do - case command (fst result) of - ViewWorkspace -> do - X11.withDefaultDisplay $ \d -> do - let Just s = name `List.elemIndex` map workspace_name workspaces - switchDesktop d (fromIntegral s) - - ShiftWindowToWorkspace _ -> do - X11.withDefaultDisplay $ \d -> - let - Just s = name `List.elemIndex` map workspace_name workspaces - in - windowToDesktop d activeWindow (fromIntegral s) - - ShiftWindowToAndViewWorkspace _ -> do - X11.withDefaultDisplay $ \d -> do - let Just s = name `List.elemIndex` map workspace_name workspaces - windowToDesktop d activeWindow (fromIntegral s) - switchDesktop d (fromIntegral s) - - _ -> - return () - - -switchDesktop :: X11.Display -> CLong -> IO () -switchDesktop d s = - X11.allocaXEvent $ \e -> do - X11.setEventType e X11.clientMessage - X11.setClientMessageEvent' e w X11._NET_CURRENT_DESKTOP 32 [fromIntegral s,0,0,0,0] - X11.sendEvent d w False mask e - where - w = X11.defaultRootWindow d - mask = X11.structureNotifyMask - - -windowToDesktop :: X11.Display -> X11.Window -> CLong -> IO () -windowToDesktop d w s = - X11.allocaXEvent $ \e -> do - X11.setEventType e X11.clientMessage - X11.setClientMessageEvent' e (fromIntegral w) X11._NET_WM_DESKTOP 32 [fromIntegral s,0,0,0,0] - X11.sendEvent d (fromIntegral w) True mask e - where - mask = X11.substructureRedirectMask .|. X11.substructureNotifyMask - - -run :: Handle -> IO Event -> State -> IO (State, Action) -run o getEvent = rec . Right where - rec = \case - Right q -> - redraw o q >> getEvent >>= processEvent q >>= rec - Left q -> - return q - - -installHandlers :: [(Signal, IO ())] -> IO () -installHandlers = - mapM_ (\(s, h) -> installHandler s (Catch h) Nothing) - - -processEvent :: State -> Event -> IO (Either (State, Action) State) -processEvent q = \case - EScan (ScanKey s) -> do - let - key = Text.pack s - (q', action) = keymap key q - - realizeAction = \case - None -> - return $ Right q' - - FocusWorkspace name -> do - return $ Left (q', FocusWorkspace name) - - realizeAction action - - EScan mouseInfo@ScanMouse{} -> - Right <$> mousemap mouseInfo q - EShutdown -> - return $ Left (q,None) - EResize w h -> - return $ Right q - { termWidth = w, termHeight = h - , flashMessage = Plain $ "resize " <> Text.show (w,h) - - , workspaceViewportHeight = newWorkspaceViewportHeight - , workspaceViewportOffset = newWorkspaceViewportOffset - } - where - newWorkspaceViewportHeight = h - 2 {- input line + status line -} - - newWorkspaceViewportOffset = - if newWorkspaceViewportHeight > workspaceViewportHeight q then - max 0 $ workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight) - - else if newWorkspaceViewportHeight <= workspaceCursor q - workspaceViewportOffset q then - workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight) - - else - workspaceViewportOffset q - - -moveWorkspaceCursor :: Int -> State -> State -moveWorkspaceCursor i q@State{..} = - q - { workspaceCursor = newWorkspaceCursor - , workspaceViewportOffset = newWorkspaceViewportOffset - } - where - newWorkspaceCursor = max 0 $ min (workspaceCursor + i) $ length foundWorkspaces - 1 - - newWorkspaceViewportOffset = - if newWorkspaceCursor < workspaceViewportOffset then - newWorkspaceCursor - - else if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then - newWorkspaceCursor - workspaceViewportHeight + 1 - - else - workspaceViewportOffset - - -setCount :: Int -> State -> State -setCount i q = q { count = i } - -keymap :: Text -> State -> ( State, Action ) - -keymap s - | [ "\ESC[4" - , Text.decimal -> Right (termHeightPixels, "") - , Text.unsnoc -> Just (Text.decimal -> Right (termWidthPixels, "") , 't') - ] <- Text.split (==';') s - = \q -> - ( q { termHeightPixels, termWidthPixels } - , None - ) - -keymap s - | [ "\ESC[6" - , Text.decimal -> Right (charHeight, "") - , Text.unsnoc -> Just (Text.decimal -> Right (charWidth, "") , 't') - ] <- Text.split (==';') s - = \q -> - ( q { charHeight, charWidth } - , None - ) - --- Up -keymap "\ESC[A" = \q@State{..} -> - ( moveWorkspaceCursor count q & setCount 1 - , None - ) - --- Down -keymap "\ESC[B" = \q@State{..} -> - ( moveWorkspaceCursor (-count) q & setCount 1 - , None - ) - --- PgUp -keymap "\ESC[5~" = \q@State{..} -> - ( moveWorkspaceCursor (count * max 1 (workspaceViewportHeight - 1)) q & setCount 1 - , None - ) - --- PgDn -keymap "\ESC[6~" = \q@State{..} -> - ( moveWorkspaceCursor (-count * max 1 (workspaceViewportHeight - 1)) q & setCount 1 - , None - ) - --- Right -keymap "\ESC[C" = \q@State{..} -> - ( q { buffer = Buffer.move Buffer.CharsForward 1 buffer } - , None - ) - --- Left -keymap "\ESC[D" = \q@State{..} -> - ( q { buffer = Buffer.move Buffer.CharsBackward 1 buffer } - , None - ) - --- Home -keymap "\ESC[H" = \q@State{..} -> - ( q { ex_offsetY = ex_offsetY - 1 } - , None - ) -keymap "\ESC[7~" = \q@State{..} -> - ( q { ex_offsetY = ex_offsetY - 1 } - , None - ) - --- End -keymap "\ESC[F" = \q@State{..} -> - ( q { ex_offsetY = ex_offsetY + 1 } - , None - ) -keymap "\ESC[8~" = \q@State{..} -> - ( q { ex_offsetY = ex_offsetY + 1 } - , None - ) - --- Backspace -keymap "\b" = \q@State{..} -> - ( updateFoundWorkspaces q { buffer = Buffer.delete Buffer.CharsBackward 1 buffer } - , None - ) -keymap "\DEL" = \q@State{..} -> - ( updateFoundWorkspaces q { buffer = Buffer.delete Buffer.CharsBackward 1 buffer } - , None - ) - -keymap "\n" = \q -> - ( q - , maybe None (FocusWorkspace . workspace_name) (lookupCursoredWorkspace q) - ) - -keymap s - | Text.length s == 1 - , [c] <- Text.unpack s - , Char.isPrint c - = \q0 -> - let - q = updateFoundWorkspaces q0 { buffer = Buffer.insertChar c (buffer q0) } - in - ( q - , case lookupCursoredWorkspace q of - Just Workspace{workspace_focused,workspace_name} -> - if length (foundWorkspaces q) == 1 then - if not workspace_focused then - FocusWorkspace workspace_name - - else - None - - else - None - - Nothing -> - None - ) - -keymap s = \q -> - ( displayKey s q - , None - ) - -updateFoundWorkspaces :: State -> State -updateFoundWorkspaces q@State{..} = - q { foundWorkspaces = newFoundWorkspaces - , workspaceCursor = max 0 $ min workspaceCursor $ length newFoundWorkspaces - 1 - } - where - f = Text.isPrefixOf (Text.pack (Buffer.showBuffer buffer)) - - newFoundWorkspaces = - map fst . List.sortOn (workspaceSortKey . snd) . filter (f . fst) . Map.toList $ workspaces - - -- smaller is "more important" - workspaceSortKey ws@Workspace{..} = - ( not $ isWorkspaceUrgent ws -- urgent workspaces are most importsnt - , workspace_focused -- focused workspace is least important - , List.null workspace_windows -- non-empty workspaces are more important - , workspace_name -- sort by name - ) - - isWorkspaceUrgent = List.any window_urgent . workspace_windows - - -mousemap :: Scan -> State -> IO State -mousemap info = displayMouse info - -displayKey :: Text -> State -> State -displayKey s q = q { flashMessage = Plain $ Text.show s } - -displayMouse :: Scan -> State -> IO State -displayMouse info q = - return q { flashMessage = SGR [38,5,202] $ Plain $ Text.show info } - - -winchHandler :: Handle -> (Event -> IO ()) -> IO () -winchHandler h putEvent = do - hPutStr h "\ESC[14t" -- query terminal width / height (in pixels) - hPutStr h "\ESC[16t" -- query character width / height - Term.hSize h >>= \case - Just Term.Window {Term.width = width, Term.height = height} -> - putEvent $ EResize width height - Nothing -> - return () - - -redraw :: Handle -> State -> IO () -redraw o q@State{..} = do - Text.hPutStr o . pp $ - "\ESC[H" - <> (mintercalate "\n" $ map eraseRight2 $ render0 q) - <> workspacePreview - hFlush o - where - - workspacePreview :: Blessings Text - workspacePreview = - let - previewWidth = paddingRight * charWidth :: Int - previewHeight = round $ (fromIntegral previewWidth :: Double) / fromIntegral screenWidth * fromIntegral screenHeight :: Int - previewGeometry = Geometry - { geometry_width = fromIntegral previewWidth - , geometry_height = fromIntegral previewHeight - , geometry_x = fromIntegral $ termWidthPixels - previewWidth - , geometry_y = fromIntegral $ ex_offsetY - } - in - fromMaybe "" (renderWorkspacePreview previewGeometry q <$> lookupCursoredWorkspace q) - - - renderWorkspacePreview :: Geometry -> State -> Workspace -> Blessings Text - renderWorkspacePreview geometry qq = - Plain . Text.decodeUtf8With (\_ _ -> Nothing) . Pager.renderWorkspacePreview geometry qq - - - maxWidth = termWidth - paddingRight - - paddingRight = 10 - - eraseRight2 s = - if Blessings.length s < maxWidth then - s <> SGR [38,5,234] (Plain $ Text.pack $ replicate (maxWidth - Blessings.length s) '@') - else - s - - -render0 :: State -> [Blessings Text] -render0 q@State{..} = - map (Blessings.take maxWidth) ((shownWorkspacesPadding <> shownWorkspaces) `join` (shownWindowsPadding <> fromMaybe mempty shownWindows)) <> - [prompt <> inputLine] <> - [statusLine] - where - - prompt = SGR [38,5,147] "> " - - inputLine = Blessings.take (maxWidth - Blessings.length prompt) (renderBuffer q) - - statusLine = - ls <> sp <> rs - where - ln = Blessings.length ls - ls = - (Blessings.take termWidth - (SGR [38,5,242] flashMessage <> Plain (Text.show count))) - - sn = termWidth - ln - rn - sp = - (SGR [38,5,234] $ Plain $ Text.pack $ replicate sn '#') - - rn = Blessings.length rs - rs = - case command of - ViewWorkspace -> SGR [38,5,236] "view" - ShiftWindowToWorkspace _ -> SGR [38,5,236] "shift" - ShiftWindowToAndViewWorkspace _ -> SGR [38,5,236] "sh+vi" - - - maxWidth = termWidth - paddingRight - - paddingRight = 10 - - n = termHeight - 2 - - shownWorkspaces :: [Blessings Text] - shownWorkspaces = - reverse $ map showWorkspace $ zip [workspaceViewportOffset..] (take n (drop workspaceViewportOffset $ foundWorkspaces')) - where - foundWorkspaces' = catMaybes $ map (flip Map.lookup workspaces) foundWorkspaces - - shownWorkspacesPadding = replicate (n - length shownWorkspaces) (SGR [38,5,234] "~") - - showWorkspace :: (Int, Workspace) -> Blessings Text - showWorkspace (index, Workspace{..}) = - let - isUrgent = any window_urgent workspace_windows - - (ls,rs) = Text.splitAt (Buffer.length buffer) workspace_name - marker = - if index == workspaceCursor then - SGR [38,5,177] "> " - else - Plain " " - - fgColor = - if isUrgent then - SGR [38,5,196] - else if workspace_focused then - SGR [38,5,238] - else if length workspace_windows == 0 then - SGR [38,5,246] - else - id - in - marker <> SGR [48,5,023] (fgColor (Plain ls)) <> fgColor (Plain rs) - - shownWindows :: Maybe [Blessings Text] - - shownWindows = - take (length shownWorkspaces) . map (SGR [38,5,236] . Plain . window_title) . workspace_windows <$> lookupCursoredWorkspace q - - shownWindowsPadding = replicate (n - maybe 0 length shownWindows) (SGR [38,5,234] "~") - - -renderBuffer :: State -> Blessings Text -renderBuffer State{buffer=(ls0,rs0)} = - let - ls = Text.pack ls0 - rs = Text.pack rs0 - in - case Text.uncons rs of - Just (c, rs') -> - Plain ls <> SGR [48,5,200] (Plain $ Text.singleton c) <> Plain rs' - - Nothing -> - let - c = ' ' - in - Plain ls <> SGR [48,5,200] (Plain $ Text.singleton c) <> Plain rs - - -join :: [Blessings Text] -> [Blessings Text] -> [Blessings Text] -join ls rs = - zipWith (<>) lsFilled rs - where - lsWidth = maximum $ map Blessings.length ls - lsFilled = map (lsFill lsWidth) ls - lsFill n s = - if Blessings.length s < n then - s <> SGR [38,5,234] (Plain (Text.pack (replicate (n - Blessings.length s) '#') <> Text.singleton '|')) - else - s <> SGR [38,5,234] (Plain (Text.singleton '|')) - - -lookupCursoredWorkspace :: State -> Maybe Workspace -lookupCursoredWorkspace State{..} = - flip Map.lookup workspaces =<< foundWorkspaces !!? workspaceCursor diff --git a/src/pager.hs b/src/pager.hs new file mode 100644 index 0000000..41c6eec --- /dev/null +++ b/src/pager.hs @@ -0,0 +1,646 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Main (main) where + +import Blessings.Text (Blessings(Plain,SGR),pp) +import Control.Concurrent +import Control.Monad (forM) +import Control.Monad (forever) +import Data.Bits ((.|.),testBit) +import Data.Default (def) +import Data.Function ((&)) +import Data.List.Extra ((!!?)) +import Data.Maybe (catMaybes,fromMaybe) +import Data.Monoid.Extra (mintercalate) +import Data.Set (Set) +import Data.Text (Text) +import Foreign.C.Types (CLong) +import Much.Screen (Screen(Screen), withScreen) +import Pager.Types +import Scanner +import State (State(..)) +import System.Environment (getArgs) +import System.IO +import System.Posix.Signals (Handler(Catch), Signal, installHandler, sigINT) +import qualified Blessings.Internal as Blessings +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Extra as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Read as Text +import qualified Graphics.X11 as X11 +import qualified Graphics.X11.EWMH as X11; +import qualified Graphics.X11.Extra as X11 +import qualified Graphics.X11.Xlib.Extras as X11 +import qualified Hack.Buffer as Buffer +import qualified Hack.Buffer.Extra as Buffer +import qualified Pager.Sixelerator as Pager +import qualified System.Console.Terminal.Size as Term + + +getGeometry :: X11.Display -> X11.Window -> IO Geometry +getGeometry d w = do + (_, x, y, width, height, _, _) <- X11.getGeometry d w + return Geometry + { geometry_x = fromIntegral x + , geometry_y = fromIntegral y + , geometry_width = fromIntegral width + , geometry_height = fromIntegral height + } + +getWorkspaces :: X11.Display -> Geometry -> Set X11.Window -> IO [Workspace] +getWorkspaces display screenGeometry focusWindows = do + let rootWindow = X11.defaultRootWindow display + + currentDesktop <- fromMaybe 0 <$> X11.getCurrentDesktop display + + workspaces <- do + names <- zip [0..] . fromMaybe [] <$> X11.getDesktopNames display + ws <- + forM names $ \(index, name) -> do + return Workspace + { workspace_geometry = screenGeometry + , workspace_focused = currentDesktop == index + , workspace_name = Text.pack name + , workspace_windows = [] + } + return $ Map.fromList $ zip [0..] ws + + clientList <- + maybe [] (map fromIntegral) <$> + X11.getWindowProperty32 display X11._NET_CLIENT_LIST rootWindow + + let + f w = do + title <- X11.getWindowTitle display w + desktop <- fromMaybe 0 <$> X11.getWindowDesktop display w + geometry <- getGeometry display w + + wm_hints <- X11.getWMHints display w + let urgent = testBit (X11.wmh_flags wm_hints) X11.urgencyHintBit + + let + window = + Window + { window_id = fromIntegral w + , window_title = Text.pack $ fromMaybe "" title + , window_geometry = geometry + , window_focused = Set.member w focusWindows + , window_urgent = urgent + } + + return ( window, desktop ) + + clientList' <- mapM f clientList + + return + $ map (\ws -> ws { workspace_windows = + uncurry (<>) $ + List.partition window_focused (workspace_windows ws) + }) + $ Map.elems + $ foldr + (\(w, i) -> + Map.adjust (\ws -> ws { workspace_windows = w : workspace_windows ws }) + i + ) + workspaces + clientList' + + +main :: IO () +main = do + args <- getArgs + let + ( commandFromArgs, focusWindows ) = + let readInt s = + case Text.decimal (Text.pack s) of + Right (i, "") -> + i + _ -> + (-1) + in + case args of + "shift" : focusWindows_ -> + ( ShiftWindowToWorkspace undefined, map readInt focusWindows_ ) + + "shiftview" : focusWindows_ -> + ( ShiftWindowToAndViewWorkspace undefined, map readInt focusWindows_ ) + + "view" : focusWindows_ -> + ( ViewWorkspace, map readInt focusWindows_ ) + + _ -> + error $ "bad arguments: " <> show args + + + Just activeWindow <- X11.withDefaultDisplay X11.getActiveWindow + + screenGeometry <- + X11.withDefaultDisplay $ \display -> do + let rootWindow = X11.defaultRootWindow display + getGeometry display rootWindow + + workspaces <- + X11.withDefaultDisplay $ \display -> do + getWorkspaces display screenGeometry (Set.fromList focusWindows) + + let screen0 = Screen False NoBuffering (BlockBuffering $ Just 4096) + [ 1000 -- X & Y on button press and release + , 1005 -- UTF-8 mouse mode + , 1047 -- use alternate screen buffer + , 80 -- enable sixel scrolling + ] + [ 25 -- hide cursor + ] + result <- do + withFile "/dev/tty" ReadWriteMode $ \i -> + withFile "/dev/tty" WriteMode $ \o -> + withScreen i o screen0 $ \_ -> do + (putEvent, getEvent) <- do + v <- newEmptyMVar + return (putMVar v, takeMVar v) + + let q1 = + updateFoundWorkspaces $ def + { command = commandFromArgs + , screenHeight = geometry_height screenGeometry + , screenWidth = geometry_width screenGeometry + , termBorder = 2 + , workspaces = + let + f workspace@Workspace{workspace_name} = ( workspace_name, workspace ) + in + Map.fromList (map f workspaces) + } + signalHandlers = + [ (sigINT, putEvent EShutdown) + , (28, winchHandler i putEvent) + ] + + installHandlers signalHandlers + + winchHandler i putEvent + + threadIds <- mapM forkIO + [ + forever $ + scan i >>= putEvent . EScan + ] + + result <- run o getEvent q1 + + mapM_ killThread threadIds + + return result + + + case snd result of + FocusWorkspace name -> do + case command (fst result) of + ViewWorkspace -> do + X11.withDefaultDisplay $ \d -> do + let Just s = name `List.elemIndex` map workspace_name workspaces + switchDesktop d (fromIntegral s) + + ShiftWindowToWorkspace _ -> do + X11.withDefaultDisplay $ \d -> + let + Just s = name `List.elemIndex` map workspace_name workspaces + in + windowToDesktop d activeWindow (fromIntegral s) + + ShiftWindowToAndViewWorkspace _ -> do + X11.withDefaultDisplay $ \d -> do + let Just s = name `List.elemIndex` map workspace_name workspaces + windowToDesktop d activeWindow (fromIntegral s) + switchDesktop d (fromIntegral s) + + _ -> + return () + + +switchDesktop :: X11.Display -> CLong -> IO () +switchDesktop d s = + X11.allocaXEvent $ \e -> do + X11.setEventType e X11.clientMessage + X11.setClientMessageEvent' e w X11._NET_CURRENT_DESKTOP 32 [fromIntegral s,0,0,0,0] + X11.sendEvent d w False mask e + where + w = X11.defaultRootWindow d + mask = X11.structureNotifyMask + + +windowToDesktop :: X11.Display -> X11.Window -> CLong -> IO () +windowToDesktop d w s = + X11.allocaXEvent $ \e -> do + X11.setEventType e X11.clientMessage + X11.setClientMessageEvent' e (fromIntegral w) X11._NET_WM_DESKTOP 32 [fromIntegral s,0,0,0,0] + X11.sendEvent d (fromIntegral w) True mask e + where + mask = X11.substructureRedirectMask .|. X11.substructureNotifyMask + + +run :: Handle -> IO Event -> State -> IO (State, Action) +run o getEvent = rec . Right where + rec = \case + Right q -> + redraw o q >> getEvent >>= processEvent q >>= rec + Left q -> + return q + + +installHandlers :: [(Signal, IO ())] -> IO () +installHandlers = + mapM_ (\(s, h) -> installHandler s (Catch h) Nothing) + + +processEvent :: State -> Event -> IO (Either (State, Action) State) +processEvent q = \case + EScan (ScanKey s) -> do + let + key = Text.pack s + (q', action) = keymap key q + + realizeAction = \case + None -> + return $ Right q' + + FocusWorkspace name -> do + return $ Left (q', FocusWorkspace name) + + realizeAction action + + EScan mouseInfo@ScanMouse{} -> + Right <$> mousemap mouseInfo q + EShutdown -> + return $ Left (q,None) + EResize w h -> + return $ Right q + { termWidth = w, termHeight = h + , flashMessage = Plain $ "resize " <> Text.show (w,h) + + , workspaceViewportHeight = newWorkspaceViewportHeight + , workspaceViewportOffset = newWorkspaceViewportOffset + } + where + newWorkspaceViewportHeight = h - 2 {- input line + status line -} + + newWorkspaceViewportOffset = + if newWorkspaceViewportHeight > workspaceViewportHeight q then + max 0 $ workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight) + + else if newWorkspaceViewportHeight <= workspaceCursor q - workspaceViewportOffset q then + workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight) + + else + workspaceViewportOffset q + + +moveWorkspaceCursor :: Int -> State -> State +moveWorkspaceCursor i q@State{..} = + q + { workspaceCursor = newWorkspaceCursor + , workspaceViewportOffset = newWorkspaceViewportOffset + } + where + newWorkspaceCursor = max 0 $ min (workspaceCursor + i) $ length foundWorkspaces - 1 + + newWorkspaceViewportOffset = + if newWorkspaceCursor < workspaceViewportOffset then + newWorkspaceCursor + + else if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then + newWorkspaceCursor - workspaceViewportHeight + 1 + + else + workspaceViewportOffset + + +setCount :: Int -> State -> State +setCount i q = q { count = i } + +keymap :: Text -> State -> ( State, Action ) + +keymap s + | [ "\ESC[4" + , Text.decimal -> Right (termHeightPixels, "") + , Text.unsnoc -> Just (Text.decimal -> Right (termWidthPixels, "") , 't') + ] <- Text.split (==';') s + = \q -> + ( q { termHeightPixels, termWidthPixels } + , None + ) + +keymap s + | [ "\ESC[6" + , Text.decimal -> Right (charHeight, "") + , Text.unsnoc -> Just (Text.decimal -> Right (charWidth, "") , 't') + ] <- Text.split (==';') s + = \q -> + ( q { charHeight, charWidth } + , None + ) + +-- Up +keymap "\ESC[A" = \q@State{..} -> + ( moveWorkspaceCursor count q & setCount 1 + , None + ) + +-- Down +keymap "\ESC[B" = \q@State{..} -> + ( moveWorkspaceCursor (-count) q & setCount 1 + , None + ) + +-- PgUp +keymap "\ESC[5~" = \q@State{..} -> + ( moveWorkspaceCursor (count * max 1 (workspaceViewportHeight - 1)) q & setCount 1 + , None + ) + +-- PgDn +keymap "\ESC[6~" = \q@State{..} -> + ( moveWorkspaceCursor (-count * max 1 (workspaceViewportHeight - 1)) q & setCount 1 + , None + ) + +-- Right +keymap "\ESC[C" = \q@State{..} -> + ( q { buffer = Buffer.move Buffer.CharsForward 1 buffer } + , None + ) + +-- Left +keymap "\ESC[D" = \q@State{..} -> + ( q { buffer = Buffer.move Buffer.CharsBackward 1 buffer } + , None + ) + +-- Home +keymap "\ESC[H" = \q@State{..} -> + ( q { ex_offsetY = ex_offsetY - 1 } + , None + ) +keymap "\ESC[7~" = \q@State{..} -> + ( q { ex_offsetY = ex_offsetY - 1 } + , None + ) + +-- End +keymap "\ESC[F" = \q@State{..} -> + ( q { ex_offsetY = ex_offsetY + 1 } + , None + ) +keymap "\ESC[8~" = \q@State{..} -> + ( q { ex_offsetY = ex_offsetY + 1 } + , None + ) + +-- Backspace +keymap "\b" = \q@State{..} -> + ( updateFoundWorkspaces q { buffer = Buffer.delete Buffer.CharsBackward 1 buffer } + , None + ) +keymap "\DEL" = \q@State{..} -> + ( updateFoundWorkspaces q { buffer = Buffer.delete Buffer.CharsBackward 1 buffer } + , None + ) + +keymap "\n" = \q -> + ( q + , maybe None (FocusWorkspace . workspace_name) (lookupCursoredWorkspace q) + ) + +keymap s + | Text.length s == 1 + , [c] <- Text.unpack s + , Char.isPrint c + = \q0 -> + let + q = updateFoundWorkspaces q0 { buffer = Buffer.insertChar c (buffer q0) } + in + ( q + , case lookupCursoredWorkspace q of + Just Workspace{workspace_focused,workspace_name} -> + if length (foundWorkspaces q) == 1 then + if not workspace_focused then + FocusWorkspace workspace_name + + else + None + + else + None + + Nothing -> + None + ) + +keymap s = \q -> + ( displayKey s q + , None + ) + +updateFoundWorkspaces :: State -> State +updateFoundWorkspaces q@State{..} = + q { foundWorkspaces = newFoundWorkspaces + , workspaceCursor = max 0 $ min workspaceCursor $ length newFoundWorkspaces - 1 + } + where + f = Text.isPrefixOf (Text.pack (Buffer.showBuffer buffer)) + + newFoundWorkspaces = + map fst . List.sortOn (workspaceSortKey . snd) . filter (f . fst) . Map.toList $ workspaces + + -- smaller is "more important" + workspaceSortKey ws@Workspace{..} = + ( not $ isWorkspaceUrgent ws -- urgent workspaces are most importsnt + , workspace_focused -- focused workspace is least important + , List.null workspace_windows -- non-empty workspaces are more important + , workspace_name -- sort by name + ) + + isWorkspaceUrgent = List.any window_urgent . workspace_windows + + +mousemap :: Scan -> State -> IO State +mousemap info = displayMouse info + +displayKey :: Text -> State -> State +displayKey s q = q { flashMessage = Plain $ Text.show s } + +displayMouse :: Scan -> State -> IO State +displayMouse info q = + return q { flashMessage = SGR [38,5,202] $ Plain $ Text.show info } + + +winchHandler :: Handle -> (Event -> IO ()) -> IO () +winchHandler h putEvent = do + hPutStr h "\ESC[14t" -- query terminal width / height (in pixels) + hPutStr h "\ESC[16t" -- query character width / height + Term.hSize h >>= \case + Just Term.Window {Term.width = width, Term.height = height} -> + putEvent $ EResize width height + Nothing -> + return () + + +redraw :: Handle -> State -> IO () +redraw o q@State{..} = do + Text.hPutStr o . pp $ + "\ESC[H" + <> (mintercalate "\n" $ map eraseRight2 $ render0 q) + <> workspacePreview + hFlush o + where + + workspacePreview :: Blessings Text + workspacePreview = + let + previewWidth = paddingRight * charWidth :: Int + previewHeight = round $ (fromIntegral previewWidth :: Double) / fromIntegral screenWidth * fromIntegral screenHeight :: Int + previewGeometry = Geometry + { geometry_width = fromIntegral previewWidth + , geometry_height = fromIntegral previewHeight + , geometry_x = fromIntegral $ termWidthPixels - previewWidth + , geometry_y = fromIntegral $ ex_offsetY + } + in + fromMaybe "" (renderWorkspacePreview previewGeometry q <$> lookupCursoredWorkspace q) + + + renderWorkspacePreview :: Geometry -> State -> Workspace -> Blessings Text + renderWorkspacePreview geometry qq = + Plain . Text.decodeUtf8With (\_ _ -> Nothing) . Pager.renderWorkspacePreview geometry qq + + + maxWidth = termWidth - paddingRight + + paddingRight = 10 + + eraseRight2 s = + if Blessings.length s < maxWidth then + s <> SGR [38,5,234] (Plain $ Text.pack $ replicate (maxWidth - Blessings.length s) '@') + else + s + + +render0 :: State -> [Blessings Text] +render0 q@State{..} = + map (Blessings.take maxWidth) ((shownWorkspacesPadding <> shownWorkspaces) `join` (shownWindowsPadding <> fromMaybe mempty shownWindows)) <> + [prompt <> inputLine] <> + [statusLine] + where + + prompt = SGR [38,5,147] "> " + + inputLine = Blessings.take (maxWidth - Blessings.length prompt) (renderBuffer q) + + statusLine = + ls <> sp <> rs + where + ln = Blessings.length ls + ls = + (Blessings.take termWidth + (SGR [38,5,242] flashMessage <> Plain (Text.show count))) + + sn = termWidth - ln - rn + sp = + (SGR [38,5,234] $ Plain $ Text.pack $ replicate sn '#') + + rn = Blessings.length rs + rs = + case command of + ViewWorkspace -> SGR [38,5,236] "view" + ShiftWindowToWorkspace _ -> SGR [38,5,236] "shift" + ShiftWindowToAndViewWorkspace _ -> SGR [38,5,236] "sh+vi" + + + maxWidth = termWidth - paddingRight + + paddingRight = 10 + + n = termHeight - 2 + + shownWorkspaces :: [Blessings Text] + shownWorkspaces = + reverse $ map showWorkspace $ zip [workspaceViewportOffset..] (take n (drop workspaceViewportOffset $ foundWorkspaces')) + where + foundWorkspaces' = catMaybes $ map (flip Map.lookup workspaces) foundWorkspaces + + shownWorkspacesPadding = replicate (n - length shownWorkspaces) (SGR [38,5,234] "~") + + showWorkspace :: (Int, Workspace) -> Blessings Text + showWorkspace (index, Workspace{..}) = + let + isUrgent = any window_urgent workspace_windows + + (ls,rs) = Text.splitAt (Buffer.length buffer) workspace_name + marker = + if index == workspaceCursor then + SGR [38,5,177] "> " + else + Plain " " + + fgColor = + if isUrgent then + SGR [38,5,196] + else if workspace_focused then + SGR [38,5,238] + else if length workspace_windows == 0 then + SGR [38,5,246] + else + id + in + marker <> SGR [48,5,023] (fgColor (Plain ls)) <> fgColor (Plain rs) + + shownWindows :: Maybe [Blessings Text] + + shownWindows = + take (length shownWorkspaces) . map (SGR [38,5,236] . Plain . window_title) . workspace_windows <$> lookupCursoredWorkspace q + + shownWindowsPadding = replicate (n - maybe 0 length shownWindows) (SGR [38,5,234] "~") + + +renderBuffer :: State -> Blessings Text +renderBuffer State{buffer=(ls0,rs0)} = + let + ls = Text.pack ls0 + rs = Text.pack rs0 + in + case Text.uncons rs of + Just (c, rs') -> + Plain ls <> SGR [48,5,200] (Plain $ Text.singleton c) <> Plain rs' + + Nothing -> + let + c = ' ' + in + Plain ls <> SGR [48,5,200] (Plain $ Text.singleton c) <> Plain rs + + +join :: [Blessings Text] -> [Blessings Text] -> [Blessings Text] +join ls rs = + zipWith (<>) lsFilled rs + where + lsWidth = maximum $ map Blessings.length ls + lsFilled = map (lsFill lsWidth) ls + lsFill n s = + if Blessings.length s < n then + s <> SGR [38,5,234] (Plain (Text.pack (replicate (n - Blessings.length s) '#') <> Text.singleton '|')) + else + s <> SGR [38,5,234] (Plain (Text.singleton '|')) + + +lookupCursoredWorkspace :: State -> Maybe Workspace +lookupCursoredWorkspace State{..} = + flip Map.lookup workspaces =<< foundWorkspaces !!? workspaceCursor -- cgit v1.2.3