diff options
Diffstat (limited to 'src/desktop-pager.hs')
| -rw-r--r-- | src/desktop-pager.hs | 642 |
1 files changed, 642 insertions, 0 deletions
diff --git a/src/desktop-pager.hs b/src/desktop-pager.hs new file mode 100644 index 0000000..2af362a --- /dev/null +++ b/src/desktop-pager.hs @@ -0,0 +1,642 @@ +{-# 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 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 + + wm_state <- + maybe [] (map fromIntegral) <$> + X11.getWindowProperty32 display X11._NET_WM_STATE w + + let urgent = + testBit (X11.wmh_flags wm_hints) X11.urgencyHintBit || + elem X11._NET_WM_STATE_DEMANDS_ATTENTION wm_state + + 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 + + -- DEBUG: hPutStrLn hderp "XXX 5" >> hFlush hderp + + case snd result of + FocusWorkspace name -> do + --wmpost (manager (fst result)) ("/workspace/" <> Text.unpack name <> "/view") () + case command (fst result) of + --ViewWorkspace -> + -- wmpost manager ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ()) + ViewWorkspace -> do + -- XXX [xmonad-http] wmpost manager ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ()) + X11.withDefaultDisplay $ \d -> do + let Just s = name `List.elemIndex` map workspace_name workspaces + X11.switchToDesktop d (fromIntegral s) + + ShiftWindowToWorkspace window -> do + -- XXX [xmonad-http] wmpost manager ("/workspace/" <> Text.unpack name <> "/shift/" <> Text.unpack wid) () :: IO (Maybe ()) + + X11.withDefaultDisplay $ \d -> + let + Just s = name `List.elemIndex` map workspace_name workspaces + in + --debug (name, s, activeWindow, window) >> + --X11.moveWindowToDesktop d activeWindow (fromIntegral s) + X11.moveWindowToDesktop d (fromIntegral window) (fromIntegral s) + + ShiftWindowToAndViewWorkspace window -> do + -- XXX [xmonad-http] wmpost manager ("/workspace/" <> Text.unpack name <> "/shiftview/" <> show wid) () :: IO (Maybe ()) + X11.withDefaultDisplay $ \d -> do + let Just s = name `List.elemIndex` map workspace_name workspaces + --X11.moveWindowToDesktop d activeWindow (fromIntegral s) + X11.moveWindowToDesktop d (fromIntegral window) (fromIntegral s) + X11.switchToDesktop d (fromIntegral s) + + _ -> + return () + + +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 |