rename to desktop-pagerewmh

To avoid conflict with https://hackage.haskell.org/package/pager

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