diff options
Diffstat (limited to 'src/pager.hs')
| -rw-r--r-- | src/pager.hs | 642 |
1 files changed, 0 insertions, 642 deletions
diff --git a/src/pager.hs b/src/pager.hs deleted file mode 100644 index 2af362a..0000000 --- a/src/pager.hs +++ /dev/null @@ -1,642 +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 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 |