diff options
Diffstat (limited to 'app/Main.hs')
| -rw-r--r-- | app/Main.hs | 240 |
1 files changed, 240 insertions, 0 deletions
diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..8dc5d5f --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.Identity +import Data.Bits +import Data.List +import Data.Map qualified as M +import GHC.Ptr (Ptr) +import Graphics.X11 qualified as X +import Graphics.X11.Xft qualified as X +import Graphics.X11.Xlib.Extras qualified as X +import Pretty qualified as P +import Sensor +import Ui hiding (Env) +import Ui qualified +import UnliftIO.STM + +data Env = Env + { dpy :: X.Display, + win :: X.Window, + swidth :: Int, + sheight :: Int, + wwidth :: Int, + wheight :: Int, + wleft :: Int, + wtop :: Int, + gc :: X.GC, + pixm :: X.Pixmap, + fnt :: X.XftFont, + drw :: X.XftDraw, + cmap :: X.Colormap, + vis :: X.Visual + } + +type Colors = M.Map (P.Intensity, P.Color) X.XftColor + +data State = State + { dirty :: Bool, + ui :: Ui TVar P.Doc + } + +main :: IO () +main = do + bracket createWindow destroyWindow $ \(env, stateT) -> + withColors env (run env stateT) + +data LastRun = LastRun + { pUi :: Ui Identity P.Doc, + lUi :: Ui' + } + +run :: Env -> TVar State -> Colors -> IO () +run env stateT colors = do + let loop = (loop . Just =<<) . go + loop Nothing + where + go Nothing = do + pUi <- atomically do + state@State {..} <- readTVar stateT + writeTVar stateT state {dirty = False} + pollUi ui + lUi <- paint env colors Nothing pUi + pure (LastRun pUi lUi) + go (Just (LastRun {pUi = pUi', lUi = lUi'})) = do + (pUi, dirty) <- atomically do + state@State {..} <- readTVar stateT + pUi <- pollUi ui + checkSTM (dirty || pUi /= pUi') + writeTVar stateT state {dirty = False} + pure (pUi, dirty) + lUi <- paint env colors (if dirty then Nothing else Just lUi') pUi + pure (LastRun pUi lUi) + +processEvents :: Ptr X.XEvent -> Env -> TVar State -> IO () +processEvents ev env@(Env {..}) stateT = do + timeOut <- X.waitForEvent dpy 1_000_000_000 + unless timeOut do + processEvent ev env stateT + processEvents ev env stateT + +processEvent :: Ptr X.XEvent -> Env -> TVar State -> IO () +processEvent ev (Env {..}) stateT = do + X.nextEvent dpy ev + e <- X.getEvent ev + if + | X.ExposeEvent {} <- e -> atomically do + state <- readTVar stateT + writeTVar stateT state {dirty = True} + | otherwise -> pure () + +paint :: + Env -> + Colors -> + Maybe Ui' -> + Ui Identity P.Doc -> + IO Ui' +paint Env {..} colors Nothing ui = do + let env' = Ui.Env {..} + ui' <- layOutUi env' ui + renderUi env' colors ui' + X.copyArea dpy pixm win gc 0 0 (fi wwidth) (fi wheight) 0 0 + X.sync dpy False + pure ui' +paint Env {..} colors (Just ui') ui = do + let env' = Ui.Env {..} + ui'' <- layOutUi env' ui + renderUi' env' colors ui' ui'' + X.copyArea dpy pixm win gc 0 0 (fi wwidth) (fi wheight) 0 0 + X.sync dpy False + pure ui'' + +destroyWindow :: (Env, TVar State) -> IO () +destroyWindow (Env {..}, _) = do + X.destroyWindow dpy win + +createWindow :: IO (Env, TVar State) +createWindow = do + dpy <- X.openDisplay "" + let scrn = X.defaultScreen dpy + scr = X.defaultScreenOfDisplay dpy + root = X.defaultRootWindow dpy + trueColor = 4 + Just vinfo <- X.matchVisualInfo dpy scrn 32 trueColor + let cls = X.inputOutput + dpth = X.visualInfo_depth vinfo + vis = X.visualInfo_visual vinfo + vmsk = X.cWColormap .|. X.cWBorderPixel .|. X.cWBackingPixel .|. X.cWOverrideRedirect + swidth = fi (X.displayWidth dpy scrn) + sheight = fi (X.displayHeight dpy scrn) + wwidth = swidth - 16 + wheight = 32 + wleft = 8 + wtop = 8 + cmap <- X.createColormap dpy root vis X.allocNone + win <- X.allocaSetWindowAttributes $ \attr -> do + X.set_colormap attr cmap + X.set_border_pixel attr 0 + X.set_background_pixel attr 0 + X.set_override_redirect attr True + X.createWindow dpy root (fi wleft) (fi wtop) (fi wwidth) (fi wheight) 0 dpth cls vis vmsk attr + atom <- X.internAtom dpy "ATOM" True + wmState <- X.internAtom dpy "_NET_WM_STATE" False + wmStateSticky <- X.internAtom dpy "_NET_WM_STATE_STICKY" False + wmStateAbove <- X.internAtom dpy "_NET_WM_STATE_ABOVE" False + wmWindowType <- X.internAtom dpy "_NET_WM_WINDOW_TYPE" False + wmWindowTypeDock <- X.internAtom dpy "_NET_WM_WINDOW_TYPE_DOCK" False + wmStrut <- X.internAtom dpy "_NET_WM_STRUT" False + wmStrutPartial <- X.internAtom dpy "_NET_WM_STRUT_PARTIAL" False + X.changeProperty32 dpy win wmState atom X.propModeReplace $ + [ fi wmStateAbove, + fi wmStateSticky + ] + X.changeProperty32 dpy win wmWindowType atom X.propModeReplace $ + [ fi wmWindowTypeDock + ] + X.changeProperty32 dpy win wmStrut atom X.propModeReplace $ + [0, 0, fi wheight + 8, 0] + X.changeProperty32 dpy win wmStrutPartial atom X.propModeReplace $ + [0, 0, fi wheight + 8, 0, 0, 0, 0, 0, fi wleft, fi wwidth, 0, 0] + pixm <- X.createPixmap dpy win (fi wwidth) (fi wheight) dpth + gc <- X.createGC dpy win + drw <- X.xftDrawCreate dpy pixm vis cmap + fnt <- X.xftFontOpen dpy scr "Free Mono:size=15" + X.mapWindow dpy win + let dirty = True + ui <- + runSensorM . initUi . Ui $ + intercalate [lit " "] $ + [ [sens wmWorkspaces], + [sens wmName, fill], + [lit "cpu ", sens cpu], + [lit "mem ", sens mem], + [lit "disk ", sens disk], + [lit "io ", sens io], + [lit "net ", sens net], + [lit "snd ", sens Sensor.snd], + [lit "bat ", sens bat], + [lit "date ", sens date], + [lit "time ", sens time] + ] + let env = Env {..} + stateT <- newTVarIO State {..} + void $ forkIO $ X.allocaXEvent $ \ev -> forever do + processEvents ev env stateT + pure (env, stateT) + +withColors :: Env -> (Colors -> IO a) -> IO a +withColors Env {..} act = do + X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Black)) $ \black -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Red)) $ \red -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Green)) $ \green -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Yellow)) $ \yellow -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Blue)) $ \blue -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Magenta)) $ \magenta -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Cyan)) $ \cyan -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.White)) $ \white -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Black)) $ \dullBlack -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Red)) $ \dullRred -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Green)) $ \dullGreen -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Yellow)) $ \dullYellow -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Blue)) $ \dullBlue -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Magenta)) $ \dullMagenta -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Cyan)) $ \dullCyan -> do + X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.White)) $ \dullWhite -> do + let colors = + M.fromList + [ ((P.Vivid, P.Black), black), + ((P.Vivid, P.Red), red), + ((P.Vivid, P.Green), green), + ((P.Vivid, P.Yellow), yellow), + ((P.Vivid, P.Blue), blue), + ((P.Vivid, P.Magenta), magenta), + ((P.Vivid, P.Cyan), cyan), + ((P.Vivid, P.White), white), + ((P.Dull, P.Black), dullBlack), + ((P.Dull, P.Red), dullRred), + ((P.Dull, P.Green), dullGreen), + ((P.Dull, P.Yellow), dullYellow), + ((P.Dull, P.Blue), dullBlue), + ((P.Dull, P.Magenta), dullMagenta), + ((P.Dull, P.Cyan), dullCyan), + ((P.Dull, P.White), dullWhite) + ] + + act colors + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +clamp :: (Ord a) => a -> a -> a -> a +clamp mi ma = max mi . min ma |