From f51618000e1d96543e5e0ad72219855e9dea42d8 Mon Sep 17 00:00:00 2001 From: tv Date: Fri, 4 Jun 2021 00:37:48 +0200 Subject: wip --- .gitignore | 3 + README.md | 11 + TODO | 45 +++ build | 39 +++ pager.cabal | 60 +++- pager.nix | 19 ++ read-jsons | Bin 0 -> 2157272 bytes read-jsons.hs | 140 ++++++++ shell.nix | 22 ++ src/Much/Screen.hs | 32 ++ src/Pager/Rasterizer.hs | 131 ++++++++ src/Pager/Types.hs | 20 +- src/Sixel.hs | 172 ++++++++++ src/State.hs | 92 ++++++ src/krebs.hs | 24 ++ src/main.hs | 847 ++++++++++++++++++++++++++++++++++++++++++++++++ sway.get_tree.json | 487 ++++++++++++++++++++++++++++ workspace.txt | 35 ++ 18 files changed, 2176 insertions(+), 3 deletions(-) create mode 100644 .gitignore create mode 100644 README.md create mode 100644 TODO create mode 100755 build create mode 100644 pager.nix create mode 100755 read-jsons create mode 100644 read-jsons.hs create mode 100644 shell.nix create mode 100644 src/Much/Screen.hs create mode 100644 src/Pager/Rasterizer.hs create mode 100644 src/Sixel.hs create mode 100644 src/State.hs create mode 100644 src/krebs.hs create mode 100644 src/main.hs create mode 100644 sway.get_tree.json create mode 100644 workspace.txt diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b42ce69 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +/dist-newstyle +/.graveyard +/tmp diff --git a/README.md b/README.md new file mode 100644 index 0000000..d9494ee --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ + + + + + + + + +cabal2nix . > pager.nix && nix-shell +./build +tmp/main diff --git a/TODO b/TODO new file mode 100644 index 0000000..e86edbe --- /dev/null +++ b/TODO @@ -0,0 +1,45 @@ + + +1.1 define Pager.API.Types +1.2 provide Pager.API.Types via XMonad.Web +1.3 purge X11 and XMonad types from pager + + + + +- transient mode: close on change [optional, e.g. when openend wia Menu button] +- persistent mode + - sticky + +- refresh (^L, \v) +- list window names on right pane (showing urgenct, allow selecting) +- hightlight selected window [blue?] +- show urgent workspaces on bottom +- show current even more on bottom (and greyed out, don't quickjump there) +- show workspace count (filtered/all) + +- notifications + +- multi display support +- xinerama + +- persistent prefixes +- tab completion + + +- get live updates from window manager (e.g. urgency) + +# bugfixes +- remove workspace preview when there is no match + +# ideas +- allow marking windows for quick swich to +- jump to marked windo (Menu > F1..) + + + +- allow starting pager with the state as parameter, this would allow to run it without requiring XMonad.API + + +- add caching? .graveyard/caching.hs (need to enable sixel scrolling) + TODO cache :: Map workspaceName (Maybe (windows,sixelText)) invalidate cache when windows have changed diff --git a/build b/build new file mode 100755 index 0000000..83033d2 --- /dev/null +++ b/build @@ -0,0 +1,39 @@ +#! /bin/sh +# usage: ./build [{dev,prod}] + +set -efu + +main() { + case ${1-dev} in + dev) build_dev;; + prod) build_prod;; + *) echo "$0: bad mode: $1" >&2; exit 1;; + esac +} + +build_dev() { + ghc -Wall \ + -i$HOME/stockholm/tv/5pkgs/haskell/xmonad-tv/src \ + -isrc \ + -odir tmp \ + -hidir tmp \ + src/main.hs \ + -threaded \ + -O0 \ + -o tmp/main +} + +# TODO for prod, don't -i external packages (libraries) +build_prod() { + ghc -Wall \ + -i$HOME/stockholm/tv/5pkgs/haskell/xmonad-tv/src \ + -isrc \ + -odir tmp \ + -hidir tmp \ + src/main.hs \ + -threaded \ + -O3 \ + -o tmp/main +} + +main "$@" diff --git a/pager.cabal b/pager.cabal index b3df3c3..beb66a6 100644 --- a/pager.cabal +++ b/pager.cabal @@ -6,13 +6,69 @@ license: MIT author: tv maintainer: tv@krebsco.de build-type: Simple +--category: System +--synopsis: window manager agnostic desktop pager +--description: window manager agnostic desktop pager :) + +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 + ghc-options: -Wall -threaded -with-rtsopts=-N + hs-source-dirs: src + build-depends: base >= 4.13 && < 5 + , aeson + , data-default + , blessings + , bytestring + , hack + , probability + , scanner + , speculate + , split + , text + , terminal-size + -- TODO hack + , http-client + , http-types + , unix + , time + , containers + , io-streams + , optparse-applicative + , network + , pager + + -- TODO remove stuff for xmonad-web + --, transformers + -- END xmonad-web + + --, X11 + --, xmonad + --, xmonad-aeson + -- TODO , xmonad-web + --, xmonad-tv + other-modules: Much.Screen + , Pager.Rasterizer + , Pager.Types + , Sixel + , State library - build-depends: base + build-depends: + base , aeson , template-haskell , text default-language: Haskell2010 exposed-modules: Pager.Types - ghc-options: -O2 -Wall + ghc-options: -Wall hs-source-dirs: src diff --git a/pager.nix b/pager.nix new file mode 100644 index 0000000..5f0de90 --- /dev/null +++ b/pager.nix @@ -0,0 +1,19 @@ +{ mkDerivation, aeson, base, blessings, bytestring, containers +, data-default, hack, http-client, http-types, io-streams, network +, optparse-applicative, probability, scanner, speculate, split +, stdenv, template-haskell, terminal-size, text, time, unix +}: +mkDerivation { + pname = "pager"; + version = "1.0.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ aeson base template-haskell text ]; + executableHaskellDepends = [ + aeson base blessings bytestring containers data-default hack + http-client http-types io-streams network optparse-applicative + probability scanner speculate split terminal-size text time unix + ]; + license = stdenv.lib.licenses.mit; +} diff --git a/read-jsons b/read-jsons new file mode 100755 index 0000000..9d456f0 Binary files /dev/null and b/read-jsons differ diff --git a/read-jsons.hs b/read-jsons.hs new file mode 100644 index 0000000..0f9e973 --- /dev/null +++ b/read-jsons.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings, DeriveGeneric, NoMonomorphismRestriction, RankNTypes, BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +module Main where + +import Control.Exception (catch) +import Control.Monad (forever) +import Data.Bool (bool) +import qualified Data.Text as Text +import qualified Data.Text.Read as Text +import qualified Data.Text.IO as Text +import qualified Data.Char as Char +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson (Parser) +--import qualified Data.ByteString.Streaming.Aeson as Aeson (streamParse) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as ByteString.Lazy +--import Data.JsonStream.Parser (value, arrayOf, (.:), Parser) +--import Data.Aeson (FromJSON, parseJSON, withObject) +import qualified Data.Aeson.TH as TH (deriveJSON, defaultOptions, defaultTaggedObject, Options(fieldLabelModifier,constructorTagModifier,sumEncoding),tagFieldName) +import Data.Text (Text) +import Data.Function ((&)) +--import Streaming +--import qualified Streaming.Prelude as S +import System.IO.Streams (Generator, InputStream, OutputStream) +import qualified System.IO.Streams as Streams +import Control.Applicative +import qualified Data.Aeson as Aeson +import Data.ByteString +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import System.IO (stdin, stderr) +import qualified System.IO as String (hPutStrLn) +import System.IO (hFlush) +import GHC.IO.Handle.FD (fdToHandle) +import System.IO.Streams hiding (stdin, stderr) +import System.IO.Streams.Attoparsec (parseFromStream) +import System.IO.Streams.Attoparsec (ParseException) +import Options.Applicative + +data Options = Options + { optionsSignalInputURI :: Maybe Text + , optionsControlOutputURI :: Maybe Text + , optionsDebugOutputURI :: Maybe Text + } + deriving (Show) + +--main :: IO () +--main = do +-- options <- execParser optionsParser +-- putStrLn +-- (concat ["Hello, ", optVal options, ", the flag is ", show (optFlag options)]) +-- where +optionsParser :: ParserInfo Options +optionsParser = + info + (helper <*> versionOption <*> programOptions) + (fullDesc <> progDesc "optparse example" <> + header + "optparse-example - a small example program for optparse-applicative") + where + versionOption :: Parser (a -> a) + versionOption = infoOption "0.0" (long "version" <> help "Show version") + programOptions :: Parser Options + programOptions = + Options + <$> optional (strOption $ long "signal" <> metavar "URI") -- value "default <> help ".." + <*> optional (strOption $ long "control" <> metavar "URI") + <*> optional (strOption $ long "debug" <> metavar "URI") + + + +data Msg = Msg + { msg_text :: Maybe Text + } | Time { time_value :: Double } + deriving (Show) + +$(TH.deriveJSON TH.defaultOptions + { TH.constructorTagModifier = Prelude.map Char.toLower + , TH.fieldLabelModifier = Prelude.tail . Prelude.dropWhile (/='_') + , TH.sumEncoding = TH.defaultTaggedObject { TH.tagFieldName = "type" } + } ''Msg) + + +--parseJSONFromStream :: FromJSON a => InputStream ByteString -> IO a +--parseJSONFromStream = parseJSON <$> parseFromStream json' + + +handleFromURI = \case + Just s | ["fd", Text.decimal -> Right (h, "")] <- Text.split (==':') s -> do + -- TODO exceptions? + Right . Just <$> fdToHandle h + + Just s -> + return $ Left $ "unsupported URI: " <> s + + Nothing -> + return $ Right Nothing + + +-- while jq -cn '[{type:"msg",value:"\(now)"},{"type":"time","value":now}][]'; do sleep 1; echo 121231.2; done | (exec 3<&0 4>&1 5>&2; exec xterm -e ./read-jsons --signal=fd:3 --control=fd:4 --debug=fd:5) +main :: IO () +main = do + options <- execParser optionsParser + print options + + jsonOut <- fdToHandle 4 + debugOutHandle <- fdToHandle 5 + + -- TODO specify protocol + -- TODO http+unix:/path/to/socket (TODO client vs server) + -- TODO fd: + maybeSignalInputHandle <- handleFromURI $ optionsSignalInputURI options + + case maybeSignalInputHandle of + Right (Just signalInputHandle) -> do + String.hPutStrLn debugOutHandle $ "signal input handle: " <> show signalInputHandle + + --let notEOF s = if ByteString.null s then Nothing else Just s + -- TODO Data.ByteString.Extra.hGetMaybe + let maybeSome = bool Nothing . Just <*> not . ByteString.null + let hGetMaybe h c = maybeSome <$> ByteString.hGet h c + + let parse stream = Aeson.fromJSON <$> parseFromStream Aeson.json' stream :: IO (Aeson.Result Msg) + + + makeInputStream (hGetMaybe signalInputHandle 1) >>= forever . ((>>=String.hPutStrLn debugOutHandle . show) . parse) + -- TODO `catch` \e -> Prelude.putStrLn ("Caught " <> show (e :: ParseException)) + + Right Nothing -> + hPutStrLn debugOutHandle $ "signal input disabled" + + Left error -> do + Text.hPutStrLn debugOutHandle $ "failed to open signal input: " <> error diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..836da25 --- /dev/null +++ b/shell.nix @@ -0,0 +1,22 @@ +{ nixpkgs ? import {}, compiler ? "default", doBenchmark ? false }: + +let + + inherit (nixpkgs) pkgs; + + haskellPackages = if compiler == "default" + then pkgs.haskellPackages + else pkgs.haskell.packages.${compiler}; + + variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id; + + drv = variant (haskellPackages.callPackage ./pager.nix { + }); + +in + + pkgs.lib.overrideDerivation drv.env (oldAttrs: { + buildInputs = [ + pkgs.cabal-install + ]; + }) diff --git a/src/Much/Screen.hs b/src/Much/Screen.hs new file mode 100644 index 0000000..47bb90c --- /dev/null +++ b/src/Much/Screen.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE RecordWildCards #-} +module Much.Screen (Screen(..), setScreen, withScreen) where + +import Control.Exception +import Data.List +import System.IO + +data Screen = Screen + { stdinEcho :: Bool + , stdinBufferMode :: BufferMode + , stdoutBufferMode :: BufferMode + , decsetPm :: [Int] + , decrstPm :: [Int] + } + +setScreen :: Screen -> IO Screen +setScreen Screen{..} = get <* set where + get = Screen <$> hGetEcho stdin + <*> hGetBuffering stdin + <*> hGetBuffering stdout + <*> pure decrstPm + <*> pure decsetPm + set = do + hSetEcho stdin stdinEcho + hSetBuffering stdin stdinBufferMode + hSetBuffering stdout stdoutBufferMode + hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decsetPm) ++ "h" + hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decrstPm) ++ "l" + hFlush stdout + +withScreen :: Screen -> (Screen -> IO a) -> IO a +withScreen s = bracket (setScreen s) setScreen diff --git a/src/Pager/Rasterizer.hs b/src/Pager/Rasterizer.hs new file mode 100644 index 0000000..821e4cc --- /dev/null +++ b/src/Pager/Rasterizer.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +-- TODO rename to Pager.Sixelerator or something +module Pager.Rasterizer where + +import Data.ByteString (ByteString) +import Data.Maybe (catMaybes) +--import Graphics.X11.Xlib.Types (Dimension,Position,Rectangle(..)) +import qualified Sixel +import Sixel (PaletteColor) +import State (State(..)) +--import qualified XMonad.Web.Types +import Pager.Types + + +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 + --workspaceX = fromIntegral $ geometry_x previewGeometry :: Int + --workspaceY = fromIntegral $ geometry_y previewGeometry + + -- TODO workspaceFirstBandOffset = workspaceY - floor (fromIntegral workspaceY / 6 :: Double) * 6 + -- TODO workspaceFirstBandHeight = 6 - workspaceFirstBandOffset + + -- TODO workspaceSkipBandCount = floor $ fromIntegral workspaceHeight / (6 :: Double) + -- TODO? workspaceTotalBandCount = ceiling $ fromIntegral (workspaceFirstBandOffset + workspaceHeight) / (6 :: Double) :: Integer + -- TODO? workspaceLastBandHeight = workspaceHeight - (workspaceTotalBandCount - 1) * 6 + workspaceFirstBandOffset + + 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 -- #ex_offsetY + 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 + + --palette = map fromIntegral [0..length rgbColors - 1] + + --colors = mconcat $ map (uncurry setColorMapRegister) (zip palette rgbColors) + + --channels = splitChannels palette canvas + --scanlines = toScanlines (fromIntegral workspaceWidth) channels + --bitbands = toBitbands (fromIntegral workspaceWidth) scanlines + --bitbands6 = toBitbands6 bitbands + --bytebands = toBytebands bitbands6 + --sixelbands = toSixelbands bytebands + --sixelbandsRLE = toSixelbandsRLE sixelbands + --sixeldata = toSixeldata (fromIntegral workspaceX) sixelbandsRLE + + + 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..2cec025 100644 --- a/src/Pager/Types.hs +++ b/src/Pager/Types.hs @@ -5,6 +5,24 @@ import Data.Aeson.TH (Options(fieldLabelModifier), deriveJSON, defaultOptions) import Data.Text (Text) +data Action + = None + -- | FocusWindow Int (Maybe Text) + | FocusWorkspace Text + -- | MoveWindowToWorkspace Int Text + -- | CopyWindowToWorkspace Int Text + | Batch Action Action + +instance Monoid Action where + mempty = None + +instance Semigroup Action where + x <> None = x + None <> x = x + Batch x1 x2 <> Batch x3 x4 = x1 <> x2 <> x3 <> x4 + Batch x1 x2 <> x3 = x1 <> x2 <> x3 + x1 <> x2 = Batch x1 x2 + data Geometry = Geometry { geometry_x :: Int , geometry_y :: Int @@ -24,7 +42,7 @@ 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) diff --git a/src/Sixel.hs b/src/Sixel.hs new file mode 100644 index 0000000..9bda65a --- /dev/null +++ b/src/Sixel.hs @@ -0,0 +1,172 @@ +{-# 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) + +-- TODO rename to RegisteredColor, IndexedColor? +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 + + +-- TODO what's the correct name? +-- TODO reword: channels :: [BitArray Int] +-- TODO reword: XXX channels must be sorted by color index (to compute sixeldata) +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) + + +-- TODO maybe use BitArray +-- 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 + + +-- #gitginore TODO use Vector.imap instead of map zip [0..]? +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..9f55743 --- /dev/null +++ b/src/State.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} +module State where + +import qualified Data.Char +import Data.Default (Default,def) +import Data.Text (Text) +import Data.Maybe (catMaybes) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Read as Text +import Control.Monad (forever) +import Blessings.Text (Blessings(Plain,SGR),pp) +import qualified Blessings.Internal as Blessings +import Control.Concurrent +import Data.Time +import Data.Map (Map) +import qualified Data.Map as Map +import Scanner +import System.IO +import qualified System.Console.Terminal.Size as Term +import System.Posix.Signals (Handler(Catch), Signal, installHandler, sigINT) +import Much.Screen (Screen(Screen), withScreen) +import qualified Hack.Buffer as Buffer +import Hack.Buffer (Buffer) +--import XMonad.Aeson () +--import qualified XMonad.Web.Types () +--import qualified XMonad +--import qualified XMonad.Web.Types +--import qualified XMonad.StackSet +import Network.HTTP.Client (Manager) +import Pager.Types + + +data State = State + { buffer :: Buffer + , count :: Int + , flashMessage :: Blessings Text + -- , now :: UTCTime + , termWidth :: Int + , termHeight :: Int + , charHeight :: Int + , charWidth :: Int + , screenWidth :: Int + , screenHeight :: Int + , termHeightPixels :: Int + , termWidthPixels :: Int + , termBorder :: Int + , manager :: Manager -- TODO not part of the state + + --Request -> Manager -> IO (Response ByteString)Source + + , workspaceViewportHeight :: Int + , workspaceViewportOffset :: Int + + , foundWorkspaces :: [Text] + --, workspaces :: [Text] + --, workspaces :: Map Text [XMonad.Web.Types.Window] + , workspaces :: Map Text Workspace + , workspaceCursor :: Int + -- + --, xmonadState :: XMonad.Web.Types.State (XMonad.Web.Types.DummyLayout Text) + , ex_offsetY :: Int -- TODO Word + } + + +instance Default State where + def = State + { buffer = Buffer.emptyBuffer + , count = 1 + , flashMessage = "Welcome to pager; quit with ^C" + -- , now = UTCTime (fromGregorian 1984 5 23) 49062 + , termWidth = 0 + , termHeight = 0 + , screenHeight = 768 -- TODO + , screenWidth = 1366 -- TODO + , charWidth = 0 + , charHeight = 0 + , termWidthPixels = 0 + , termHeightPixels = 0 + , termBorder = 0 + -- + , workspaceViewportHeight = 0 + , workspaceViewportOffset = 0 + , foundWorkspaces = [] + , workspaces = Map.empty + , workspaceCursor = 0 + -- + --, xmonadState = def + , ex_offsetY = 0 + } + + diff --git a/src/krebs.hs b/src/krebs.hs new file mode 100644 index 0000000..38170dc --- /dev/null +++ b/src/krebs.hs @@ -0,0 +1,24 @@ + + --Text.writeFile "/tmp/test" $ pp krebs + + krebs = let size = 16 in + Plain + $ Text.decodeUtf8With (\_ _ -> Nothing) + $ Sixel.render + --(Rectangle (fromIntegral $ termWidthPixels - (fromIntegral size) - 2 * termBorder) 60 size size) + (Rectangle (fromIntegral $ termWidthPixels - (fromIntegral size) - 2 * termBorder) 38 size size) + [(0,0,0),(228,0,43)] + [0,1,0,1,0,0,0,0,0,0,0,0,0,1,0,1 + ,1,1,0,1,0,0,1,1,0,1,1,0,1,1,0,1 + ,1,1,0,1,0,0,1,1,0,1,1,0,1,1,0,1 + ,0,1,1,1,0,0,0,1,0,0,1,0,0,1,1,1 + ,0,1,1,1,0,0,1,1,1,1,1,0,0,1,1,1 + ,0,0,1,0,0,1,1,1,1,1,1,1,0,0,1,0 + ,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,0 + ,0,0,0,0,0,1,1,1,1,1,1,1,0,0,0,0 + ,0,0,0,1,1,1,1,1,1,1,1,1,1,1,0,0 + ,0,0,0,1,0,0,0,1,1,1,0,0,0,1,0,0 + ,0,0,1,0,0,1,0,1,0,1,0,1,0,0,1,0 + ,0,0,1,0,0,1,0,1,0,1,0,1,0,0,1,0 + ,0,0,1,0,1,1,0,1,0,1,0,1,1,0,1,0 + ] diff --git a/src/main.hs b/src/main.hs new file mode 100644 index 0000000..0f1abbf --- /dev/null +++ b/src/main.hs @@ -0,0 +1,847 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Main where + +import qualified Data.Char as Char +import qualified Data.Aeson as Aeson +import Data.Default (def) +import Data.Function ((&)) +import qualified Data.List as List +import Data.Text (Text) +import Data.Maybe (catMaybes,fromMaybe,listToMaybe) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Read as Text +import qualified Data.Text.Encoding as Text +import Control.Monad (forever) +import Blessings.Text (Blessings(Plain,SGR),pp) +import qualified Blessings.Internal as Blessings +import Control.Concurrent +--import Data.Time +import qualified Data.Map as Map +import Pager.Types +import Scanner +import System.IO +import qualified System.Console.Terminal.Size as Term +import System.Posix.Signals (Handler(Catch), Signal, installHandler, raiseSignal, sigINT) +import Much.Screen (Screen(Screen), withScreen) +import qualified Hack.Buffer as Buffer +import Hack.Buffer (Buffer) +--import XMonad.Aeson () +--import XMonad.Web.Types () +----import qualified XMonad +--import qualified XMonad.StackSet +--import qualified XMonad.Web.Types +--import qualified Sixel +--import Sixel (PaletteColor) +import State (State(..)) +--import Graphics.X11.Xlib.Types (Dimension,Position,Rectangle(..)) +--import qualified XMonad.Web.Types +import qualified Pager.Rasterizer as Rasterizer +import System.Environment (lookupEnv) + +-- begin http client +--import Network.HTTP.Client +--import Network.HTTP.Client.Internal (Connection, openSocketConnection, makeConnection) +--import Network.Socket.ByteString (sendAll, recv) +--import qualified Control.Exception as E +--import qualified Network.Socket as NS + +import qualified Network.Socket as S +import qualified Network.Socket.ByteString as SBS +import Network.HTTP.Client +--import Network.HTTP.Client.Internal (makeConnection) +--import Network.HTTP.Types.Status (statusCode) +-- end http client + + +showText :: Show a => a -> Text +showText = Text.pack . show + + +-- TODO move to Buffer +bufferLength :: Buffer -> Int +bufferLength (ls, rs) = + length ls + length rs + + +insertChar :: Char -> Buffer -> Buffer +insertChar c (ls, rs) = (ls <> [c], rs) + +insertString :: String -> Buffer -> Buffer +insertString s (ls, rs) = (ls <> s, rs) + + +(!!?) :: [a] -> Int -> Maybe a +x !!? i | i >= 0 = listToMaybe (drop i x) +_ !!? _ = Nothing + + +lookupCursoredWorkspace :: State -> Maybe Workspace +lookupCursoredWorkspace State{..} = + flip Map.lookup workspaces =<< foundWorkspaces !!? workspaceCursor + + +---- XXX assumes that the cursor is already at the (cleared) input line +---- TODO renderInputLine looks like it wants to be -> VT () +--renderInputLine :: Maybe Int -> Mode -> Buffer -> IO () +--renderInputLine mb_cnt m (lhs, rhs) = do +-- --clearLine -- XXX do we need this clearLine? +-- renderRight $ +-- SGR [30,1] $ +-- Plain (show m) <> +-- maybe Empty +-- (("["<>) . (<>"]") . SGR [33,1] . Plain . show) +-- mb_cnt +-- renderLeft $ promptString m <> gaudySpecial [35] (lhs ++ rhs) +-- moveCursorLeft $ length $ lit rhs +-- +-- +--renderLeft :: Blessings String -> IO () +--renderLeft = putStr . pp +-- +-- +--renderRight :: Blessings String -> IO () +--renderRight a = do +-- saveCursor +-- moveCursorRight 1024 -- XXX obviously, this is a hack..^_^ +-- moveCursorLeft $ len a - 1 +-- renderLeft a +-- unsaveCursor +-- end move to Buffer + +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 + + +data Event = + --EFlash (Blessings Text) | + EScan Scan | + EShutdown | + --EReload | + EResize Int Int + --EStateGet (State -> IO ()) + deriving Show + + + +-- TODO handle exceptions / errors +wmget :: Aeson.FromJSON a => Manager -> String -> IO (Maybe a) +wmget manager path = do + -- TODO check path is absolute + let url = "http://localhost" <> path + let request = parseRequest_ url + response <- httpLbs request manager + --putStrLn $ "wmget: The status code was: " ++ (show $ statusCode $ responseStatus response) + return $ Aeson.decode $ responseBody response + +wmpost :: (Aeson.ToJSON a, Aeson.FromJSON b) => Manager -> String -> a -> IO (Maybe b) +wmpost manager path content = do + -- TODO check path is absolute + let url = "http://localhost" <> path + let request = (parseRequest_ url) { method = "POST", requestBody = RequestBodyLBS $ Aeson.encode content } + response <- httpLbs request manager + --putStrLn $ "wmpost: The status code was: " ++ (show $ statusCode $ responseStatus response) + return $ Aeson.decode $ responseBody response + +--post path content = do +-- -- TODO check path is absolute +-- let url = "http://localhost" <> path +-- let request = parseRequest_ { method = "POST", requestBody = RequestBodyLBS $ Aeson.encode content } +-- httpLbs request manager + + +-- TODO put displayNumber in some lib +-- https://tronche.com/gui/x/xlib/display/opening.html (where's the manual in NixOS?) +-- hostname:number.screen_number +--displayNumber :: String -> Maybe Int +--displayNumber = +-- takeWhile Char.isDigit . dropWhile (==':') + + + +main :: IO () +main = do + -- TODO dedup with xmonad API + display <- read . fromMaybe "0" . fmap (takeWhile Char.isDigit . dropWhile (==':')) <$> lookupEnv "DISPLAY" :: IO Int + + -- TODO use $XMONAD_CACHE_DIR + -- API says: -- TODO runtimeDir instead of cacheDir + cacheDir <- fromMaybe undefined <$> lookupEnv "XMONAD_CACHE_DIR" + let xmonadSocketPath = cacheDir <> "/warp-" <> show display <> ".sock" + manager <- newUnixDomainSocketManager xmonadSocketPath + + --response <- get "/state" + + Just workspaces <- wmget manager "/pager/state" :: IO (Maybe [Workspace]) + + --putStrLn $ "The status code was: " ++ (show $ statusCode $ responseStatus response) + --let body = responseBody response + ----print body + --let Just XMonad.Web.Types.State{..} = Aeson.decode body :: Maybe (XMonad.Web.Types.State (XMonad.Web.Types.DummyLayout Text)) + + ----x <- getXMonadState + --print (111 :: Int) + --mapM_ (putStrLn . XMonad.StackSet.tag) (XMonad.Web.Types.s_workspaces state) + --print (112 :: Int) + --mapM_ (putStrLn . show . XMonad.StackSet.stack) (XMonad.Web.Types.s_workspaces state) + --print (113 :: Int) + --mapM_ (putStrLn . show . XMonad.StackSet.layout) (XMonad.Web.Types.s_workspaces state) + --print (114 :: Int) + --mapM_ (putStrLn . show) (XMonad.Web.Types.s_windows state) + ----print (115 :: Int) + ----print state + --print (999 :: Int) + + 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 + ] + [ 25 -- hide cursor + , 80 -- disable sixel scrolling + ] + withScreen screen0 $ \_ -> do + (putEvent, getEvent) <- do + v <- newEmptyMVar + return (putMVar v, takeMVar v) + + let q1 = + updateFoundWorkspaces $ def + { manager = manager + , termBorder = 2 -- TODO config + , workspaces = + let + f workspace@Workspace{workspace_name} = ( workspace_name, workspace ) + in + Map.fromList (map f workspaces) + } + --windows = + -- let + -- f window@Window{window_id} = ( window_id, window ) + -- in + -- Map.fromList (map f s_windows) + signalHandlers = + [ (sigINT, putEvent EShutdown) + , (28, winchHandler putEvent) + ] + + installHandlers signalHandlers + + threadIds <- mapM forkIO + [ forever $ scan stdin >>= putEvent . EScan + ] + + winchHandler putEvent + + run getEvent q1 + + hPutStr stdout "Fin" + mapM_ killThread threadIds + + +run :: IO Event -> State -> IO () +run getEvent = rec . Right where + rec = \case + Right q -> -- do + --t <- getCurrentTime + --let q' = q { now = t } + redraw q >> getEvent >>= processEvent q >>= rec + Left _q -> return () + + +installHandlers :: [(Signal, IO ())] -> IO () +installHandlers = + mapM_ (\(s, h) -> installHandler s (Catch h) Nothing) + + +processEvent :: State -> Event -> IO (Either State State) +processEvent q = \case + EScan (ScanKey s) -> do + let + key = Text.pack s + (q', action) = keymap key q + + realizeAction = \case + None -> + return () + + Batch a1 a2 -> do + realizeAction a1 + realizeAction a2 + + FocusWorkspace name -> do + -- TODO make quitting configurable with some "quit after change focus" option + --jumpQndQuit :: State -> IO State + --jumpQndQuit q@State{manager} = do + -- case workspace_name <$> lookupCursoredWorkspace q of + -- Just name -> do + -- -- TODO response, TODO Cmd-like + -- _ <- wmpost manager ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ()) + -- raiseSignal sigINT + -- return q + -- + -- Nothing -> + -- return q + _ <- wmpost (manager q') ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ()) + raiseSignal sigINT + + -- TODO check for failures, and then Left instead of Right + realizeAction action + + return $ Right q' + + EScan mouseInfo@ScanMouse{..} -> + Right <$> mousemap mouseInfo q + EShutdown -> + return $ Left q + EResize w h -> + return $ Right q + { termWidth = w, termHeight = h + , flashMessage = Plain $ "resize " <> showText (w,h) + + , workspaceViewportHeight = newWorkspaceViewportHeight + , workspaceViewportOffset = newWorkspaceViewportOffset + } + where + -- TODO resizeWorkspaceViewport + -- TODO what if h < 0? + + newWorkspaceViewportHeight = h - 2 {- input line + status line -} + + newWorkspaceViewportOffset = + if newWorkspaceViewportHeight > workspaceViewportHeight q then + max 0 $ workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight) + + --else if workspaceCursor q >= newWorkspaceViewportHeight + workspaceViewportOffset q then + else if newWorkspaceViewportHeight <= workspaceCursor q - workspaceViewportOffset q then + workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight) + + else + workspaceViewportOffset q + + --if workspaceCursor q < workspaceViewportOffset q then + -- workspaceCursor q + + --else if workspaceCursor q >= workspaceViewportOffset q + workspaceViewportHeight q then + -- workspaceCursor q - workspaceViewportHeight q + 1 + + --else + -- workspaceViewportOffset q + + +-- negative ~ down, positive ~ up +moveWorkspaceCursor :: Int -> State -> State +moveWorkspaceCursor i q@State{..} = + --case compare i 0 of + -- LT -> moveWorkspaceCursorDown (-1) q + -- GT -> moveWorkspaceCursorUp 1 q + -- EQ -> q + q + { workspaceCursor = newWorkspaceCursor + , workspaceViewportOffset = newWorkspaceViewportOffset + } + where + newWorkspaceCursor = max 0 $ min (workspaceCursor + i) $ length foundWorkspaces - 1 + + -- TODO dedup with processEvent / EResize + newWorkspaceViewportOffset = + if newWorkspaceCursor < workspaceViewportOffset then + newWorkspaceCursor + + else if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then + newWorkspaceCursor - workspaceViewportHeight + 1 + + else + workspaceViewportOffset + + + --if newWorkspaceCursor < workspaceCursor then + -- if newWorkspaceCursor < workspaceViewportOffset then + -- newWorkspaceCursor -- TODO clamp or is it already? + -- else + -- workspaceViewportOffset + + --else if newWorkspaceCursor > workspaceCursor then + -- if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then + -- newWorkspaceCursor - workspaceViewportHeight + 1 + -- else + -- workspaceViewportOffset + + --else + -- workspaceViewportOffset + + --workspaceCursorDelta = newWorkspaceCursor - workspaceCursor + --workspaceViewportDelta = + -- if isNewWorkspaceCursorOutOfViewport then + -- workspaceCursorDelta + + -- else + -- 0 + -- + --newWorkspaceViewportOffset = workspaceViewportOffset + workspaceViewportDelta + + --isNewWorkspaceCursorOutOfViewport = + -- newWorkspaceCursor < workspaceViewportOffset || + -- newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight + + -- --if newWorkspaceCursor < workspaceViewportOffset then + -- -- workspaceViewportOffset - (workspaceCursor - newWorkspaceCursor) + + -- --else if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then + -- -- workspaceViewportOffset + (newWorkspaceCursor - workspaceCursor) + + -- --else + -- -- workspaceViewportOffset + + + --if newWorkspaceCursor < workspaceCursor then + -- if newWorkspaceCursor < workspaceViewportOffset then + -- workspaceViewportOffset - (workspaceCursor - newWorkspaceCursor) + -- else + -- workspaceViewportOffset + + --else if newWorkspaceCursor > workspaceCursor then + -- if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then + -- workspaceViewportOffset + (newWorkspaceCursor - workspaceCursor) + -- else + -- workspaceViewportOffset + + --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 + ) + +keymap "\ESCOP" = \q -> (setCount 1 q, mempty) +keymap "\ESCOQ" = \q -> (setCount 2 q, mempty) +keymap "\ESCOR" = \q -> (setCount 3 q, mempty) +keymap "\ESCOS" = \q -> (setCount 4 q, mempty) +keymap "\ESC[15~" = \q -> (setCount 5 q, mempty) +keymap "\ESC[17~" = \q -> (setCount 6 q, mempty) +keymap "\ESC[18~" = \q -> (setCount 7 q, mempty) +keymap "\ESC[19~" = \q -> (setCount 8 q, mempty) +keymap "\ESC[20~" = \q -> (setCount 9 q, mempty) +keymap "\ESC[21~" = \q -> (setCount 0 q, mempty) + +-- 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 + ) + +-- End +keymap "\ESC[F" = \q@State{..} -> + ( q { ex_offsetY = ex_offsetY + 1 } + , None + ) + +keymap "\b" = \q@State{..} -> + ( updateFoundWorkspaces q { buffer = Buffer.delete Buffer.CharsBackward 1 buffer } + , None + ) + +keymap "\n" = \q -> + ( q + , foldMap (FocusWorkspace . workspace_name) (lookupCursoredWorkspace q) + ) + +keymap s + | Text.length s == 1 + , [c] <- Text.unpack s + , Char.isPrint c + = \q0 -> + let + q = updateFoundWorkspaces q0 { buffer = insertChar c (buffer q0) } + in + ( q + , + -- TODO make the jump-when-exactly-one-match behavior configurable + case lookupCursoredWorkspace q of + Just Workspace{workspace_focused,workspace_name} -> + if length (foundWorkspaces q) == 1 then + -- TODO if length foundWorkspaces == 2 and one of the workspaces is + -- focused, then jump to the other + if not workspace_focused then + FocusWorkspace workspace_name + + else + mempty + + else + mempty + + Nothing -> + mempty + ) + +keymap s = \q -> + ( displayKey s q + , mempty + ) + + + +updateFoundWorkspaces :: State -> State +updateFoundWorkspaces q@State{..} = + q { foundWorkspaces = newFoundWorkspaces + , workspaceCursor = max 0 $ min workspaceCursor $ length newFoundWorkspaces - 1 + } + where + -- TODO filter out current workspace + 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 ScanMouse{mouseButton=1,mouseY=y} = defaultMouse1Click y +--mousemap ScanMouse{mouseButton=3,mouseY=y} = \q -> defaultMouse1Click y q >>= toggleFold +--mousemap ScanMouse{mouseButton=4} = moveTreeDown 3 +--mousemap ScanMouse{mouseButton=5} = moveTreeUp 3 +--mousemap ScanMouse{mouseButton=0} = return +mousemap info = displayMouse info + +displayKey :: Text -> State -> State +displayKey s q = q { flashMessage = Plain $ showText s } + +displayMouse :: Scan -> State -> IO State +displayMouse info q = + return q { flashMessage = SGR [38,5,202] $ Plain $ showText info } + + + + + + + +winchHandler :: (Event -> IO ()) -> IO () +winchHandler putEvent = do + -- TODO use events + --hPutStr stdout "\ESCc" -- TODO only on change + hPutStr stdout "\ESC[14t" -- query terminal width / height (in pixels) + hPutStr stdout "\ESC[16t" -- query character width / height + Term.size >>= \case + Just Term.Window {Term.width = w, Term.height = h} -> + putEvent $ EResize w h + Nothing -> + return () + + + + + + +redraw :: State -> IO () +redraw q@State{..} = do + Text.hPutStr stdout . pp $ + "\ESC[H" + <> (mintercalate "\n" $ map eraseRight2 $ render0 q) + + -- XXX this has no effect when sixel scrolling is disabled + -- <> "\ESC[5;" <> Plain (showText $ maxWidth + 2) <> "H" + + <> workspacePreview + hFlush stdout + 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 + } + --windows = + -- case foundWorkspaces of + -- [] -> [] + -- _ -> + -- let + -- cursoredWorkspace = foundWorkspaces !! workspaceCursor -- TODO safe + -- in + -- fromMaybe [] $ Map.lookup cursoredWorkspace workspaces + in + + --case foundWorkspaces of + -- [] -> "" + -- _ -> + -- let + -- cursoredWorkspace = foundWorkspaces !! workspaceCursor -- TODO safe + -- ws = fromMaybe emptyWorkspace $ Map.lookup cursoredWorkspace workspaces + -- -- TODO def + -- emptyWorkspace = Workspace + -- { workspace_geometry = Geometry 0 0 0 0 + -- , workspace_focused = False + -- , workspace_name = "" + -- , workspace_windows = [] + -- } + -- in + -- Plain $ Text.decodeUtf8With (\_ _ -> Nothing) $ Rasterizer.renderWorkspacePreview previewGeometry q ws + + fromMaybe "" (renderWorkspacePreview previewGeometry q <$> lookupCursoredWorkspace q) + + + renderWorkspacePreview :: Geometry -> State -> Workspace -> Blessings Text + renderWorkspacePreview geometry qq = + Plain . Text.decodeUtf8With (\_ _ -> Nothing) . Rasterizer.renderWorkspacePreview geometry qq + + + maxWidth = termWidth - paddingRight + + -- This is not just padding right, but also the width of the workspace preview + paddingRight = 10 {- #paddingRight put into state -} + + eraseRight2 s = + if Blessings.length s < maxWidth then + s <> SGR [38,5,234] (Plain $ Text.pack $ replicate (maxWidth - Blessings.length s) '@') + else + s + + --sub x x' c = if c == x then x' else c + --eraseRight s = + -- if Blessings.length s < termWidth + -- then s <> "\ESC[K" + -- else s + + + + + + + + + + +render0 :: State -> [Blessings Text] +render0 q@State{..} = + map (Blessings.take maxWidth) ((shownWorkspacesPadding <> shownWorkspaces) `join` (shownWindowsPadding <> fromMaybe mempty shownWindows)) <> + + -- debug workspace viewport + [SGR [38,5,147] "> " <> renderBuffer q] <> + [Blessings.take termWidth $ SGR [38,5,242] flashMessage <> Plain (showText count)] + where + maxWidth = termWidth - paddingRight + + -- This is not just padding right, but also the width of the workspace preview + paddingRight = 10 {- #paddingRight put into state -} + + -- for debugging workspace viewport + -- debug = Plain (showText (workspaceViewportOffset, workspaceViewportHeight, workspaceCursor) + + + n = termHeight - 2 {- input line + status line -} + + 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 + --windows = maybe [] workspace_windows $ Map.lookup name workspaces + + isUrgent = any window_urgent workspace_windows + + (ls,rs) = Text.splitAt (bufferLength 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) + + + --cursoredWorkspace = foundWorkspaces !! workspaceCursor -- TODO safe + --cursoredWorkspaceWindows = maybe [] workspace_windows $ Map.lookup cursoredWorkspace workspaces + + shownWindows :: Maybe [Blessings Text] + --shownWindows = take (length shownWorkspaces) $ map (SGR [38,5,236] . Plain . window_title) cursoredWorkspaceWindows + + 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] "~") + + +join :: [Blessings Text] -> [Blessings Text] -> [Blessings Text] +join ls rs = + zipWith (<>) lsFilled rs + where + --rsTruncated = map (Blessings.take 10) rs + + 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 '|')) + + + + +--joinColumns :: [Blessings.Text] -> [Blessings.Text] -> [Blessings.Text] +--joinColumns ls rs = + + + + +mintercalate :: Monoid b => b -> [b] -> b +mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t +mintercalate _ [] = mempty + + + +-- begin http client +--getXMonadState :: IO (Maybe (XMonad.Web.Types.State (XMonad.Web.Types.DummyLayout Text))) +--getXMonadState = do +-- mgr <- newManager defaultManagerSettings { +-- managerRawConnection = createUnixConnection +-- } +-- req <- parseUrl "http://localhost/state" +-- res <- httpLbs req mgr +-- let body = responseBody res +-- return $ Aeson.decode body + + +--createUnixConnection :: IO (Maybe NS.HostAddress -> String -> Int -> IO Connection) +--createUnixConnection = return $ \_ _ _ -> openUnixConnection xmonadSocketPath +-- +--openUnixConnection :: String -> IO Connection +--openUnixConnection addr = E.bracketOnError +-- (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) +-- (NS.close) +-- $ \sock -> do +-- NS.connect sock sockAddr +-- mySocketConnection sock chunksize +-- where +-- sockAddr = NS.SockAddrUnix addr +-- chunksize = 8192 +-- +--------------------------------------------------------------------------------- +---- Copied from http-client +--------------------------------------------------------------------------------- +-- +--mySocketConnection :: NS.Socket -> Int -> IO Connection +--mySocketConnection socket chunksize = makeConnection +-- (recv socket chunksize) +-- (sendAll socket) +-- (NS.close socket) + +newUnixDomainSocketManager :: FilePath -> IO Manager +newUnixDomainSocketManager path = do + let mSettings = defaultManagerSettings { managerRawConnection = return $ openUnixSocket path } + newManager mSettings + where + openUnixSocket filePath _ _ _ = do + s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol + S.connect s (S.SockAddrUnix filePath) + makeConnection (SBS.recv s 8096) + (SBS.sendAll s) + (S.close s) +-- end http client diff --git a/sway.get_tree.json b/sway.get_tree.json new file mode 100644 index 0000000..ef12656 --- /dev/null +++ b/sway.get_tree.json @@ -0,0 +1,487 @@ +{ + "id": 1, + "name": "root", + "rect": { + "x": 0, + "y": 0, + "width": 1366, + "height": 768 + }, + "focused": false, + "focus": [ + 3 + ], + "border": "none", + "current_border_width": 0, + "layout": "splith", + "orientation": "horizontal", + "percent": null, + "window_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "deco_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "geometry": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "window": null, + "urgent": false, + "marks": [ + ], + "fullscreen_mode": 0, + "nodes": [ + { + "id": 2147483647, + "name": "__i3", + "rect": { + "x": 0, + "y": 0, + "width": 1366, + "height": 768 + }, + "focused": false, + "focus": [ + 2147483646 + ], + "border": "none", + "current_border_width": 0, + "layout": "output", + "orientation": "horizontal", + "percent": null, + "window_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "deco_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "geometry": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "window": null, + "urgent": false, + "marks": [ + ], + "fullscreen_mode": 0, + "nodes": [ + { + "id": 2147483646, + "name": "__i3_scratch", + "rect": { + "x": 0, + "y": 0, + "width": 1366, + "height": 768 + }, + "focused": false, + "focus": [ + ], + "border": "none", + "current_border_width": 0, + "layout": "splith", + "orientation": "horizontal", + "percent": null, + "window_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "deco_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "geometry": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "window": null, + "urgent": false, + "marks": [ + ], + "fullscreen_mode": 1, + "nodes": [ + ], + "floating_nodes": [ + ], + "sticky": false, + "type": "workspace" + } + ], + "floating_nodes": [ + ], + "sticky": false, + "type": "output" + }, + { + "id": 3, + "name": "LVDS-1", + "rect": { + "x": 0, + "y": 0, + "width": 1366, + "height": 768 + }, + "focused": false, + "focus": [ + 4 + ], + "border": "none", + "current_border_width": 0, + "layout": "output", + "orientation": "none", + "percent": 1.0, + "window_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "deco_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "geometry": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "window": null, + "urgent": false, + "marks": [ + ], + "fullscreen_mode": 0, + "nodes": [ + { + "id": 4, + "name": "1", + "rect": { + "x": 0, + "y": 0, + "width": 1366, + "height": 768 + }, + "focused": false, + "focus": [ + 24, + 41 + ], + "border": "none", + "current_border_width": 0, + "layout": "splitv", + "orientation": "vertical", + "percent": null, + "window_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "deco_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "geometry": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "window": null, + "urgent": false, + "marks": [ + ], + "fullscreen_mode": 1, + "nodes": [ + { + "id": 24, + "name": null, + "rect": { + "x": 0, + "y": 0, + "width": 1366, + "height": 768 + }, + "focused": false, + "focus": [ + 35, + 5 + ], + "border": "none", + "current_border_width": 0, + "layout": "splith", + "orientation": "horizontal", + "percent": 1.0, + "window_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "deco_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "geometry": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "window": null, + "urgent": false, + "marks": [ + ], + "fullscreen_mode": 0, + "nodes": [ + { + "id": 5, + "name": "Alacritty", + "rect": { + "x": 0, + "y": 0, + "width": 739, + "height": 768 + }, + "focused": false, + "focus": [ + ], + "border": "pixel", + "current_border_width": 1, + "layout": "none", + "orientation": "none", + "percent": 0.54099560761346999, + "window_rect": { + "x": 1, + "y": 1, + "width": 737, + "height": 766 + }, + "deco_rect": { + "x": 0, + "y": 0, + "width": 0, + "height": 0 + }, + "geometry": { + "x": 0, + "y": 0, + "width": 800, + "height": 630 + }, + "window": null, + "urgent": false, + "marks": [ + ], + "