summaryrefslogtreecommitdiffstats
path: root/src/main.hs
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2021-06-04 00:37:48 +0200
committertv <tv@krebsco.de>2021-06-04 00:37:48 +0200
commitf51618000e1d96543e5e0ad72219855e9dea42d8 (patch)
treedc63bb05e748c008f2d816f4079e659dffe0cafb /src/main.hs
parent032cb86ff8108eb4915a692015da344a41f78506 (diff)
wipwip2
Diffstat (limited to 'src/main.hs')
-rw-r--r--src/main.hs847
1 files changed, 847 insertions, 0 deletions
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