diff options
Diffstat (limited to 'src/main.hs')
| -rw-r--r-- | src/main.hs | 693 |
1 files changed, 693 insertions, 0 deletions
diff --git a/src/main.hs b/src/main.hs new file mode 100644 index 0000000..7d956a4 --- /dev/null +++ b/src/main.hs @@ -0,0 +1,693 @@ +{-# 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.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@State{..} = \case + EScan (ScanKey s) -> + Right <$> keymap (Text.pack s) 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 then + max 0 $ workspaceViewportOffset - (newWorkspaceViewportHeight - workspaceViewportHeight) + else if workspaceCursor < newWorkspaceViewportHeight + workspaceViewportOffset then + workspaceViewportOffset + else + workspaceViewportOffset + (workspaceViewportHeight - newWorkspaceViewportHeight) + + +keymap :: Text -> State -> IO State + +keymap s + | [ "\ESC[4" + , Text.decimal -> Right (termHeightPixels, "") + , Text.unsnoc -> Just (Text.decimal -> Right (termWidthPixels, "") , 't') + ] <- Text.split (==';') s + = \q -> + return q { termHeightPixels, termWidthPixels } + +keymap s + | [ "\ESC[6" + , Text.decimal -> Right (charHeight, "") + , Text.unsnoc -> Just (Text.decimal -> Right (charWidth, "") , 't') + ] <- Text.split (==';') s + = \q -> + return q { charHeight, charWidth } + +-- Up +keymap "\ESC[A" = \q@State{..} -> + let + newWorkspaceCursor = max 0 $ min (workspaceCursor + 1) $ length foundWorkspaces - 1 + newWorkspaceViewportOffset = + -- TODO dedup with processEvent / EResize + if newWorkspaceCursor < workspaceViewportOffset + workspaceViewportHeight then + workspaceViewportOffset + else + workspaceViewportOffset + (newWorkspaceCursor - workspaceCursor) + in + return q + { workspaceCursor = newWorkspaceCursor + , workspaceViewportOffset = newWorkspaceViewportOffset + } + +-- Down +keymap "\ESC[B" = \q@State{..} -> + --return q { workspaceCursor = max 0 $ workspaceCursor - 1 } + let + newWorkspaceCursor = max 0 $ workspaceCursor - 1 + newWorkspaceViewportOffset = + -- TODO dedup with processEvent / EResize + if newWorkspaceCursor >= workspaceViewportOffset then + workspaceViewportOffset + else + workspaceViewportOffset - (workspaceCursor - newWorkspaceCursor) + in + return q + { workspaceCursor = newWorkspaceCursor + , workspaceViewportOffset = newWorkspaceViewportOffset + } + +-- Right +keymap "\ESC[C" = \q@State{..} -> + return q { buffer = Buffer.move Buffer.CharsForward 1 buffer } + +-- Left +keymap "\ESC[D" = \q@State{..} -> + return q { buffer = Buffer.move Buffer.CharsBackward 1 buffer } + +-- Home +keymap "\ESC[H" = \q@State{..} -> + return q { ex_offsetY = ex_offsetY - 1 } + +-- End +keymap "\ESC[F" = \q@State{..} -> + return q { ex_offsetY = ex_offsetY + 1 } + +keymap "\b" = \q@State{..} -> + updateFoundWorkspaces <$> return q { buffer = Buffer.delete Buffer.CharsBackward 1 buffer } + +keymap "\n" = + jumpQndQuit + +keymap s + | Text.length s == 1 + , [c] <- Text.unpack s + , Char.isPrint c + = \q@State{..} -> + return (updateFoundWorkspaces q { buffer = insertChar c buffer }) >>= \q@State{..} -> + -- TODO make the jump-when-exactly-one-match behavior configurable + if length foundWorkspaces == 1 then + + -- TODO if length foundWorkspaces == 2 and one of the workspaces is + -- focused, then jump to the other + + case workspace_focused <$> lookupCursoredWorkspace q of + Just False -> + jumpQndQuit q + _ -> + return q + else + return q + +keymap s = + displayKey s + + + +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 + + -- IfElse's Control.Monad.IfElse.awhenM: + --awhenM (workspace_name <$> lookupCursoredWorkspace) $ \name -> do + -- _ <- wmpost manager ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ()) + -- raiseSignal sigINT + --return q + + +updateFoundWorkspaces :: State -> State +updateFoundWorkspaces q@State{..} = + q { foundWorkspaces = newFoundWorkspaces + , workspaceCursor = max 0 $ min workspaceCursor $ length newFoundWorkspaces - 1 + } + where + -- TODO List.sortBy compareWorkspaces (requires workspaces to be something better than a string) + newFoundWorkspaces = filter f (Map.keys workspaces) + f = Text.isPrefixOf (Text.pack (Buffer.showBuffer buffer)) + + +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 -> IO State +displayKey s q = return 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 q = + Plain . Text.decodeUtf8With (\_ _ -> Nothing) . Rasterizer.renderWorkspacePreview geometry q + + + 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] + 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 |