diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | README.md | 5 | ||||
| -rw-r--r-- | pager.cabal | 47 | ||||
| -rw-r--r-- | src/Data/List/Extra.hs | 8 | ||||
| -rw-r--r-- | src/Data/Monoid/Extra.hs | 6 | ||||
| -rw-r--r-- | src/Data/Text/Encoding/Extra.hs | 11 | ||||
| -rw-r--r-- | src/Data/Text/Extra.hs | 8 | ||||
| -rw-r--r-- | src/Foreign/C/String/Extra.hs | 10 | ||||
| -rw-r--r-- | src/Graphics/X11/Extra.hs | 24 | ||||
| -rw-r--r-- | src/Graphics/X11/Xlib/Extras/Extra.hs | 14 | ||||
| -rw-r--r-- | src/Hack/Buffer/Extra.hs | 10 | ||||
| -rw-r--r-- | src/Much/Screen.hs | 33 | ||||
| -rw-r--r-- | src/Pager/Sixelerator.hs | 105 | ||||
| -rw-r--r-- | src/Pager/Types.hs | 22 | ||||
| -rw-r--r-- | src/Sixel.hs | 166 | ||||
| -rw-r--r-- | src/State.hs | 58 | ||||
| -rw-r--r-- | src/main.hs | 706 |
17 files changed, 1221 insertions, 13 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8075013 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/dist-newstyle diff --git a/README.md b/README.md new file mode 100644 index 0000000..2e9200a --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# Quickstart + + cabal2nix . > pager.nix + nix-shell --run 'cabal build' + tmp/main view diff --git a/pager.cabal b/pager.cabal index b3df3c3..d05c17d 100644 --- a/pager.cabal +++ b/pager.cabal @@ -7,12 +7,45 @@ author: tv <tv@krebsco.de> maintainer: tv@krebsco.de build-type: Simple -library - build-depends: base - , aeson - , template-haskell - , text +source-repository head + type: git + location: https://cgit.krebsco.de/pager + +source-repository this + type: git + location: https://cgit.krebsco.de/pager + tag: 1.0.0 + +executable pager + main-is: main.hs default-language: Haskell2010 - exposed-modules: Pager.Types - ghc-options: -O2 -Wall + ghc-options: -Wall -threaded -with-rtsopts=-N hs-source-dirs: src + build-depends: base >= 4.13 && < 5 + , X11 + , blessings + , bytestring + , containers + , data-default + , hack + , optparse-applicative + , probability + , scanner + , speculate + , split + , terminal-size + , text + , unix + other-modules: Data.List.Extra + , Data.Monoid.Extra + , Data.Text.Encoding.Extra + , Data.Text.Extra + , Foreign.C.String.Extra + , Graphics.X11.Extra + , Graphics.X11.Xlib.Extras.Extra + , Hack.Buffer.Extra + , Much.Screen + , Pager.Sixelerator + , Pager.Types + , Sixel + , State diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs new file mode 100644 index 0000000..d18bc76 --- /dev/null +++ b/src/Data/List/Extra.hs @@ -0,0 +1,8 @@ +module Data.List.Extra where + +import Data.Maybe (listToMaybe) + + +(!!?) :: [a] -> Int -> Maybe a +x !!? i | i >= 0 = listToMaybe (drop i x) +_ !!? _ = Nothing diff --git a/src/Data/Monoid/Extra.hs b/src/Data/Monoid/Extra.hs new file mode 100644 index 0000000..e484cf0 --- /dev/null +++ b/src/Data/Monoid/Extra.hs @@ -0,0 +1,6 @@ +module Data.Monoid.Extra where + + +mintercalate :: Monoid b => b -> [b] -> b +mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t +mintercalate _ [] = mempty diff --git a/src/Data/Text/Encoding/Extra.hs b/src/Data/Text/Encoding/Extra.hs new file mode 100644 index 0000000..a8e6234 --- /dev/null +++ b/src/Data/Text/Encoding/Extra.hs @@ -0,0 +1,11 @@ +module Data.Text.Encoding.Extra where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text + + +decodeUtf8Lenient :: ByteString -> Text +decodeUtf8Lenient = + Text.decodeUtf8With Text.lenientDecode diff --git a/src/Data/Text/Extra.hs b/src/Data/Text/Extra.hs new file mode 100644 index 0000000..07dd45c --- /dev/null +++ b/src/Data/Text/Extra.hs @@ -0,0 +1,8 @@ +module Data.Text.Extra where + +import Data.Text (Text) +import qualified Data.Text as Text + + +show :: Show a => a -> Text +show = Text.pack . Prelude.show diff --git a/src/Foreign/C/String/Extra.hs b/src/Foreign/C/String/Extra.hs new file mode 100644 index 0000000..a7b6dfe --- /dev/null +++ b/src/Foreign/C/String/Extra.hs @@ -0,0 +1,10 @@ +module Foreign.C.String.Extra where + +import Data.Word (Word8) +import Foreign.C.String (castCCharToChar) +import Foreign.C.Types (CChar) +import qualified Data.Char as Char + + +castCCharToWord8 :: CChar -> Word8 +castCCharToWord8 = fromIntegral . Char.ord . castCCharToChar diff --git a/src/Graphics/X11/Extra.hs b/src/Graphics/X11/Extra.hs new file mode 100644 index 0000000..bed1ba3 --- /dev/null +++ b/src/Graphics/X11/Extra.hs @@ -0,0 +1,24 @@ +module Graphics.X11.Extra where + +import Control.Exception (bracket) +import System.Environment (getEnv) +import System.IO.Unsafe (unsafePerformIO) +import qualified Graphics.X11 as X11 + + +unsafeInternAtom :: String -> Bool -> X11.Atom +unsafeInternAtom atomName onlyIfExists = + unsafePerformIO $ withDefaultDisplay $ \display -> + X11.internAtom display atomName onlyIfExists + +defaultDisplayName :: String +defaultDisplayName = + unsafePerformIO (getEnv "DISPLAY") + +withDisplay :: String -> (X11.Display -> IO a) -> IO a +withDisplay display = + bracket (X11.openDisplay display) X11.closeDisplay + +withDefaultDisplay :: (X11.Display -> IO a) -> IO a +withDefaultDisplay = + withDisplay defaultDisplayName diff --git a/src/Graphics/X11/Xlib/Extras/Extra.hs b/src/Graphics/X11/Xlib/Extras/Extra.hs new file mode 100644 index 0000000..d88bf9d --- /dev/null +++ b/src/Graphics/X11/Xlib/Extras/Extra.hs @@ -0,0 +1,14 @@ +module Graphics.X11.Xlib.Extras.Extra where + +import Data.Text (Text) +import Foreign.C.String.Extra (castCCharToWord8) +import qualified Data.ByteString as ByteString +import qualified Data.Text.Encoding.Extra as Text +import qualified Graphics.X11 as X11 +import qualified Graphics.X11.Xlib.Extras as X11 + + +getWindowPropertyText :: X11.Display -> X11.Atom -> X11.Window -> IO (Maybe Text) +getWindowPropertyText d a w = + fmap (Text.decodeUtf8Lenient . ByteString.pack . map castCCharToWord8) <$> + X11.getWindowProperty8 d a w diff --git a/src/Hack/Buffer/Extra.hs b/src/Hack/Buffer/Extra.hs new file mode 100644 index 0000000..999703c --- /dev/null +++ b/src/Hack/Buffer/Extra.hs @@ -0,0 +1,10 @@ +module Hack.Buffer.Extra where + +import Hack.Buffer (Buffer) + + +length :: Buffer -> Int +length (ls, rs) = Prelude.length ls + Prelude.length rs + +insertChar :: Char -> Buffer -> Buffer +insertChar c (ls, rs) = (ls <> [c], rs) diff --git a/src/Much/Screen.hs b/src/Much/Screen.hs new file mode 100644 index 0000000..b93847f --- /dev/null +++ b/src/Much/Screen.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE RecordWildCards #-} +module Much.Screen (Screen(..), setScreen, withScreen) where + +import Control.Exception +import Data.List +import System.IO + + +data Screen = Screen + { inputEcho :: Bool + , inputBufferMode :: BufferMode + , outputBufferMode :: BufferMode + , decsetPm :: [Int] + , decrstPm :: [Int] + } + +setScreen :: Handle -> Handle -> Screen -> IO Screen +setScreen i o Screen{..} = get <* set where + get = Screen <$> hGetEcho i + <*> hGetBuffering i + <*> hGetBuffering o + <*> pure decrstPm + <*> pure decsetPm + set = do + hSetEcho i inputEcho + hSetBuffering i inputBufferMode + hSetBuffering o outputBufferMode + hPutStr o $ "\ESC[?" ++ intercalate ";" (map show decsetPm) ++ "h" + hPutStr o $ "\ESC[?" ++ intercalate ";" (map show decrstPm) ++ "l" + hFlush o + +withScreen :: Handle -> Handle -> Screen -> (Screen -> IO a) -> IO a +withScreen i o s = bracket (setScreen i o s) (setScreen i o) diff --git a/src/Pager/Sixelerator.hs b/src/Pager/Sixelerator.hs new file mode 100644 index 0000000..c518484 --- /dev/null +++ b/src/Pager/Sixelerator.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +module Pager.Sixelerator where + +import Data.ByteString (ByteString) +import Data.Maybe (catMaybes) +import Pager.Types +import Sixel (PaletteColor) +import State (State(..)) +import qualified Sixel + + +data WindowFeature + = WindowBackground + | WindowBorder + | FocusBackground + | FocusBorder + | UrgentBackground + | UrgentBorder + + +renderWorkspacePreview :: Geometry -> State -> Workspace -> ByteString +renderWorkspacePreview previewGeometry State{screenHeight,screenWidth} Workspace{..} = + Sixel.render previewGeometry rgbColors canvas + where + workspaceHeight = fromIntegral $ geometry_height previewGeometry :: Int + workspaceWidth = fromIntegral $ geometry_width previewGeometry :: Int + + scaleX = fromIntegral workspaceWidth / fromIntegral screenWidth :: Double + scaleY = fromIntegral workspaceHeight / fromIntegral screenHeight :: Double + + -- XXX color indexes must start at 0 and be continuous (to compute sixeldata) + workspaceBackgroundColor = 0 + windowBackgroundColor = 1 + windowBorderColor = 2 + focusBackgroundColor = 3 + focusBorderColor = 4 + urgentBackgroundColor = 5 + urgentBorderColor = 6 + + rgbColors = + [ (0,0,0) -- workspace background + , (29,113,29) -- window background color + , (0,255,0) -- window border color + , (113,29,113) -- focus background color + , (255,0,255) -- focus border color + , (113,29,29) -- urgent background color + , (255,0,0) -- urgent border color + ] + + canvas = rasterize f (fromIntegral workspaceWidth) (fromIntegral workspaceHeight) + <> blankLine + where + f x y = case catMaybes (map (getWindowFeatureAt x y) workspace_windows) of + UrgentBackground:_ -> urgentBackgroundColor + UrgentBorder:_ -> urgentBorderColor + FocusBackground:_ -> focusBackgroundColor + FocusBorder:_ -> focusBorderColor + WindowBackground:_ -> windowBackgroundColor + WindowBorder:_ -> windowBorderColor + _ -> workspaceBackgroundColor + + -- XXX blank line is used in conjunction with ex_offsetY to "clean up" when moving up + -- remove this together with ex_offsetY. + blankLine = replicate workspaceWidth 0 + + getWindowFeatureAt x y Window{..} = + if isBorder then + if window_urgent then + Just UrgentBorder + else if window_focused then + Just FocusBorder + else + Just WindowBorder + else if isBackground then + if window_urgent then + Just UrgentBackground + else if window_focused then + Just FocusBackground + else + Just WindowBackground + else + Nothing + where + w_x = round (scaleX * fromIntegral (geometry_x window_geometry)) + w_y = round (scaleY * fromIntegral (geometry_y window_geometry)) + w_width = round (scaleX * fromIntegral (geometry_width window_geometry)) + w_height = round (scaleY * fromIntegral (geometry_height window_geometry)) + isBackground = + (w_x <= x && x < w_x + w_width) && + (w_y <= y && y < w_y + w_height) + isBorder = + (w_x <= x && x < w_x + w_width) && + (w_y <= y && y < w_y + w_height) && + (x == w_x || x == w_x + w_width - 1 || y == w_y || y == w_y + w_height - 1) + + +rasterize :: (Int -> Int -> PaletteColor) -> Int -> Int -> [PaletteColor] +rasterize f width height = + map f' ([0..width * height - 1] :: [Int]) + where + f' index = f x y + where + x = fromIntegral $ index `mod` width + y = floor $ fromIntegral index / (fromIntegral width :: Double) diff --git a/src/Pager/Types.hs b/src/Pager/Types.hs index 95dd837..a2ea5aa 100644 --- a/src/Pager/Types.hs +++ b/src/Pager/Types.hs @@ -1,10 +1,24 @@ {-# LANGUAGE TemplateHaskell #-} module Pager.Types where -import Data.Aeson.TH (Options(fieldLabelModifier), deriveJSON, defaultOptions) import Data.Text (Text) +import Scanner (Scan) +data Action + = None + | FocusWorkspace Text + +data Command = + ViewWorkspace | + ShiftWindowToWorkspace Int | + ShiftWindowToAndViewWorkspace Int + +data Event = + EResize Int Int | + EScan Scan | + EShutdown + data Geometry = Geometry { geometry_x :: Int , geometry_y :: Int @@ -24,9 +38,5 @@ data Workspace = Workspace { workspace_geometry :: Geometry , workspace_focused :: Bool , workspace_name :: Text - , workspace_windows :: [Window] + , workspace_windows :: [Window] -- sorted by z-order, earlier windows overlap later ones } - -$(deriveJSON defaultOptions { fieldLabelModifier = tail . dropWhile (/='_') } ''Geometry) -$(deriveJSON defaultOptions { fieldLabelModifier = tail . dropWhile (/='_') } ''Window) -$(deriveJSON defaultOptions { fieldLabelModifier = tail . dropWhile (/='_') } ''Workspace) diff --git a/src/Sixel.hs b/src/Sixel.hs new file mode 100644 index 0000000..dc49d91 --- /dev/null +++ b/src/Sixel.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Sixel + ( PaletteColor + , RGBColor + , render + ) where + +import Data.Bits (shiftL) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.Word (Word8) +import Pager.Types (Geometry(..)) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as ByteString.Char8 +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.List.Split as List (chunksOf) +import qualified Foreign.C.Types +import qualified Numeric.Probability.Trace as List (zipListWith) +import qualified Test.Speculate.Utils as Tuple (uncurry6) + + +showByteString :: Show a => a -> ByteString +showByteString = + ByteString.Char8.pack . show + + +type Bit = Foreign.C.Types.CBool + +type Sixel = (Bit, Bit, Bit, Bit, Bit, Bit) + +type PaletteColor = Word8 + +type RGBColor = (Word8, Word8, Word8) + + +render :: Geometry -> [RGBColor] -> [PaletteColor] -> ByteString +render (Geometry x y width _) rgbColors canvas = + "\ESCP0;0;q" <> colors <> sixeldata <> "\ESC\\" + where + bandsToSkip = floor (fromIntegral y / (6 :: Double)) + + paddedCanvas = + if y < 0 then + drop (-(fromIntegral y) * fromIntegral width) canvas + else + let + paddingTop = replicate (fromIntegral offsetY * fromIntegral width) 0 + offsetY = y - bandsToSkip * 6 + in + paddingTop <> canvas + + palette = map fromIntegral [0..length rgbColors - 1] + colors = mconcat $ map (uncurry setColorMapRegister) (zip palette rgbColors) + channels = splitChannels palette paddedCanvas + bitmaps = map (toScanlines width) channels + images = map (map (runLengthEncode . toByteString) . toSixels) bitmaps + sixeldata = skipBands (fromIntegral bandsToSkip) <> overstrikeBands (map (map (shiftX x)) images) + + +skipBands :: Int -> ByteString +skipBands n = + ByteString.replicate n newline + where + newline = fromIntegral (Char.ord '-') + + +shiftX :: Int -> ByteString -> ByteString +shiftX x s = + "!" <> showByteString x <> "?" <> s + + +setColorMapRegister :: PaletteColor -> RGBColor -> ByteString +setColorMapRegister i _rgbColor256@(r256,g256,b256) = + "#" <> mconcat (List.intersperse ";" (map showByteString [i, 2, r100, g100, b100])) + where + (r100,g100,b100) = (to100 r256, to100 g256, to100 b256) + to100 = round . (*(100/256 :: Double)) . fromIntegral + + +useColorMapRegister :: PaletteColor -> ByteString -> ByteString +useColorMapRegister color s = + "#" <> showByteString color <> s + + +splitChannels :: [PaletteColor] -> [PaletteColor] -> [[Bit]] +splitChannels channels canvas = + map (flip getChannel canvas) channels + where + getChannel :: PaletteColor -> [PaletteColor] -> [Bit] + getChannel color = map (bool 0 1 . (==color)) + + +toScanlines :: Int -> [Bit] -> [[Bit]] +toScanlines width = + List.chunksOf (fromIntegral width) + + +-- Turn scanlines into sixelbands. +-- Empty lines will be added as necessary to construct the final band. +toSixels :: [[Bit]] -> [[Sixel]] +toSixels = + map (Tuple.uncurry6 List.zip6) . rec + where + rec :: [[Bit]] -> [([Bit],[Bit],[Bit],[Bit],[Bit],[Bit])] + rec (a:b:c:d:e:f:rest) = (a,b,c,d,e,f) : rec rest + rec (a:b:c:d:e:[]) = (a,b,c,d,e,z) : [] + rec (a:b:c:d:[]) = (a,b,c,d,z,z) : [] + rec (a:b:c:[]) = (a,b,c,z,z,z) : [] + rec (a:b:[]) = (a,b,z,z,z,z) : [] + rec (a:[]) = (a,z,z,z,z,z) : [] + rec ([]) = [] + z = repeat 0 + + +toByteString :: [Sixel] -> ByteString +toByteString = + ByteString.pack . map ((+63) . toWord8) + + +toWord8 :: Sixel -> Word8 +toWord8 (a, b, c, d, e, f) = + shiftL (fromIntegral a) 0 + + shiftL (fromIntegral b) 1 + + shiftL (fromIntegral c) 2 + + shiftL (fromIntegral d) 3 + + shiftL (fromIntegral e) 4 + + shiftL (fromIntegral f) 5 + + +runLengthEncode :: ByteString -> ByteString +runLengthEncode input = + case ByteString.uncons input of + Just (c, input') -> + let + (c_last, n_last, out) = ByteString.foldl f (c, 1, "") input' + in + encode c_last n_last out + + Nothing -> + input + where + f :: (Word8, Int, ByteString) -> Word8 -> (Word8, Int, ByteString) + f (c, n, out) c_in = + if c_in == c then + (c, n + 1, out) + else + (c_in, 1, encode c n out) + + encode :: Word8 -> Int -> ByteString -> ByteString + encode c n output = + if n > 3 then + output <> "!" <> showByteString n <> ByteString.singleton c + else + output <> ByteString.replicate n c + + +overstrikeBands :: [[ByteString]] -> ByteString +overstrikeBands = + mconcat . List.intersperse "-" . List.zipListWith overstrikeBand + + +overstrikeBand :: [ByteString] -> ByteString +overstrikeBand = + mconcat . List.intersperse "$" . map (uncurry useColorMapRegister) . zip [0..] diff --git a/src/State.hs b/src/State.hs new file mode 100644 index 0000000..2cb1575 --- /dev/null +++ b/src/State.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} +module State where + +import Blessings.Text (Blessings) +import Data.Default (Default,def) +import Data.Map (Map) +import Data.Text (Text) +import Hack.Buffer (Buffer) +import Pager.Types +import qualified Data.Map as Map +import qualified Hack.Buffer as Buffer + + +data State = State + { buffer :: Buffer + , command :: Command + , count :: Int + , flashMessage :: Blessings Text + , termWidth :: Int + , termHeight :: Int + , charHeight :: Int + , charWidth :: Int + , screenWidth :: Int + , screenHeight :: Int + , termHeightPixels :: Int + , termWidthPixels :: Int + , termBorder :: Int + , workspaceViewportHeight :: Int + , workspaceViewportOffset :: Int + , foundWorkspaces :: [Text] + , workspaces :: Map Text Workspace + , workspaceCursor :: Int + , ex_offsetY :: Int + } + + +instance Default State where + def = State + { buffer = Buffer.emptyBuffer + , command = ViewWorkspace + , count = 1 + , flashMessage = "Welcome to pager; quit with ^C" + , termWidth = 0 + , termHeight = 0 + , screenHeight = 0 + , screenWidth = 0 + , charWidth = 0 + , charHeight = 0 + , termWidthPixels = 0 + , termHeightPixels = 0 + , termBorder = 0 + , workspaceViewportHeight = 0 + , workspaceViewportOffset = 0 + , foundWorkspaces = [] + , workspaces = Map.empty + , workspaceCursor = 0 + , ex_offsetY = 0 + } diff --git a/src/main.hs b/src/main.hs new file mode 100644 index 0000000..816aa7c --- /dev/null +++ b/src/main.hs @@ -0,0 +1,706 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Main (main) where + +import Blessings.Text (Blessings(Plain,SGR),pp) +import Control.Applicative ((<|>)) +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.Extra as X11 +import qualified Graphics.X11.Xlib.Extras as X11 +import qualified Graphics.X11.Xlib.Extras.Extra 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 + + +atom_NET_ACTIVE_WINDOW :: X11.Atom +atom_NET_ACTIVE_WINDOW = X11.unsafeInternAtom "_NET_ACTIVE_WINDOW" True + +atom_NET_CLIENT_LIST :: X11.Atom +atom_NET_CLIENT_LIST = X11.unsafeInternAtom "_NET_CLIENT_LIST" True + +atom_NET_CURRENT_DESKTOP :: X11.Atom +atom_NET_CURRENT_DESKTOP = X11.unsafeInternAtom "_NET_CURRENT_DESKTOP" True + +atom_NET_DESKTOP_NAMES :: X11.Atom +atom_NET_DESKTOP_NAMES = X11.unsafeInternAtom "_NET_DESKTOP_NAMES" True + +atom_NET_WM_DESKTOP :: X11.Atom +atom_NET_WM_DESKTOP = X11.unsafeInternAtom "_NET_WM_DESKTOP" True + +atom_NET_WM_NAME :: X11.Atom +atom_NET_WM_NAME = X11.unsafeInternAtom "_NET_WM_NAME" True + +atom_WIN_WORKSPACE :: X11.Atom +atom_WIN_WORKSPACE = X11.unsafeInternAtom "_WIN_WORKSPACE" True + +atom_WIN_WORKSPACE_NAMES :: X11.Atom +atom_WIN_WORKSPACE_NAMES = X11.unsafeInternAtom "_WIN_WORKSPACE_NAMES" True + +atom_WM_NAME :: X11.Atom +atom_WM_NAME = X11.unsafeInternAtom "WM_NAME" True + + +getActiveWindow :: X11.Display -> IO (Maybe X11.Window) +getActiveWindow d = + (fmap (fromIntegral . head) <$>) $ + X11.getWindowProperty32 d atom_NET_ACTIVE_WINDOW w + where w = X11.defaultRootWindow d + +getCurrentDesktop :: X11.Display -> IO (Maybe CLong) +getCurrentDesktop d = + (fmap head <$>) $ + X11.getWindowProperty32 d atom_NET_CURRENT_DESKTOP w <|> + X11.getWindowProperty32 d atom_WIN_WORKSPACE w + where w = X11.defaultRootWindow d + +getDesktopNames :: X11.Display -> IO (Maybe [Text]) +getDesktopNames d = do + (fmap (init . Text.split (=='\NUL')) <$>) $ + X11.getWindowPropertyText d atom_NET_DESKTOP_NAMES w <|> + X11.getWindowPropertyText d atom_WIN_WORKSPACE_NAMES w + where w = X11.defaultRootWindow d + +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 + } + +getWindowDesktop :: X11.Display -> X11.Window -> IO (Maybe CLong) +getWindowDesktop d w = + (fmap head <$>) $ + X11.getWindowProperty32 d atom_NET_WM_DESKTOP w <|> + X11.getWindowProperty32 d atom_WIN_WORKSPACE w + +getWindowTitle :: X11.Display -> X11.Window -> IO (Maybe Text) +getWindowTitle d w = + X11.getWindowPropertyText d atom_NET_WM_NAME w <|> + X11.getWindowPropertyText d atom_WM_NAME w + +getWorkspaces :: X11.Display -> Geometry -> Set X11.Window -> IO [Workspace] +getWorkspaces display screenGeometry focusWindows = do + let rootWindow = X11.defaultRootWindow display + + currentDesktop <- fromMaybe 0 <$> getCurrentDesktop display + + workspaces <- do + names <- zip [0..] . fromMaybe [] <$> getDesktopNames display + ws <- + forM names $ \(index, name) -> do + return Workspace + { workspace_geometry = screenGeometry + , workspace_focused = currentDesktop == index + , workspace_name = name + , workspace_windows = [] + } + return $ Map.fromList $ zip [0..] ws + + clientList <- + maybe [] (map fromIntegral) <$> + X11.getWindowProperty32 display atom_NET_CLIENT_LIST rootWindow + + let + f w = do + title <- getWindowTitle display w + desktop <- fromMaybe 0 <$> 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 = 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 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 + + threadIds <- mapM forkIO + [ + forever $ + scan i >>= putEvent . EScan + ] + + winchHandler i putEvent + + 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 atom_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) atom_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 + |