diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Main.hs | 77 | ||||
| -rw-r--r-- | app/Pretty.hs | 108 | ||||
| -rw-r--r-- | app/Sensor.hs | 855 | ||||
| -rw-r--r-- | app/Ui.hs | 59 |
4 files changed, 496 insertions, 603 deletions
diff --git a/app/Main.hs b/app/Main.hs index 09f0d50..66883b9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,11 +11,12 @@ module Main where import Control.Concurrent import Control.Exception import Control.Monad -import Control.Monad.Identity +import Control.Monad.Trans import Data.Bits import Data.List import Data.Map qualified as M import Data.Maybe +import Data.Sensor qualified as S import GHC.Ptr (Ptr) import Graphics.X11 qualified as X import Graphics.X11.Xft qualified as X @@ -62,7 +63,7 @@ type Colors = M.Map (P.Intensity, P.Color) X.XftColor data State = State { dirty :: Bool, - ui :: Ui TVar P.Doc + ui :: Ui (S.Sensor (S.SensorT IO) () (Block P.Doc)) } main :: IO () @@ -71,32 +72,25 @@ main = do bracket (createWindow args) 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 + -- XXX `ui` lives in state, but we treat is as if it was constant + -- XXX this is supposed to NOT wait for the next event if `state.dirty` + S.runSensorT . S.sample' go . pollUi . (.ui) =<< atomically do readTVar stateT where - go Nothing = do - pUi <- atomically do + go Nothing pUi = do + atomically do + writeTVar stateT . (\state -> state {dirty = False}) + =<< readTVar stateT + lUi <- liftIO (paint env colors Nothing pUi) + pure lUi + go (Just lUi') pUi = do + dirty <- 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) + pure dirty + lUi <- liftIO (paint env colors (if dirty then Nothing else Just lUi') pUi) + pure lUi processEvents :: Ptr X.XEvent -> Env -> TVar State -> IO () processEvents ev env@(Env {..}) stateT = do @@ -115,12 +109,7 @@ processEvent ev (Env {..}) stateT = do writeTVar stateT state {dirty = True} | otherwise -> pure () -paint :: - Env -> - Colors -> - Maybe Ui' -> - Ui Identity P.Doc -> - IO Ui' +paint :: Env -> Colors -> Maybe Ui' -> Ui (Block P.Doc) -> IO Ui' paint Env {..} colors Nothing ui = do let env' = Ui.Env {..} ui' <- layOutUi env' ui @@ -190,20 +179,22 @@ createWindow args = do drw <- X.xftDrawCreate dpy pixm vis cmap X.mapWindow dpy win let dirty = True - ui <- - runSensorM . initUi . Ui $ - intercalate [lit " "] $ - [ [sens wmWorkspaces], - [sens wmName, fill], - [lit (if args.icons then "\xf4bc " else "cpu "), sens cpu], - [lit (if args.icons then "\xf035b " else "mem "), sens mem], - [lit (if args.icons then "\xf0a0 " else "disk "), sens disk], - [lit (if args.icons then "\xf1638 " else "io "), sens io], - [lit (if args.icons then "\xf0200 " else "net "), sens net], - [lit (if args.icons then "\xf028 " else "snd "), sens Sensor.snd], - [lit (if args.icons then "\xf240 " else "bat "), sens bat], - [lit " ", sens date, lit ", ", sens time] - ] + let ui :: Ui (S.Sensor (S.SensorT IO) () (Block P.Doc)) + ui = + Ui $ + intercalate [pure (lit " ")] $ + [ [lit <$> wmWorkspaces], + [lit <$> wmName, pure fill], + [pure (lit (if args.icons then "\xf4bc " else "cpu ")), lit <$> cpu], + [pure (lit (if args.icons then "\xf035b " else "mem ")), lit <$> mem], + [pure (lit (if args.icons then "\xf0a0 " else "disk ")), lit <$> disk], + [pure (lit (if args.icons then "\xf1638 " else "io ")), lit <$> io], + [pure (lit (if args.icons then "\xf0200 " else "net ")), lit <$> net], + [pure (lit (if args.icons then "\xf028 " else "snd ")), lit <$> Sensor.snd], + [pure (lit (if args.icons then "\xf240 " else "bat ")), lit <$> bat], + [pure (lit " "), lit <$> date, pure (lit ", "), lit <$> time], + [] + ] xcolors <- do X.rmInitialize rdb <- X.rmGetStringDatabase (X.resourceManagerString dpy) diff --git a/app/Pretty.hs b/app/Pretty.hs index 8054acc..d2988a9 100644 --- a/app/Pretty.hs +++ b/app/Pretty.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} @@ -5,6 +6,7 @@ module Pretty ( Doc (..), Pretty, pretty, + Diagram, diagram, module Pretty.Color, color, @@ -28,55 +30,63 @@ instance Pretty Char where instance Pretty String where pretty = Lit Nothing -diagram :: Int -> [Float] -> Doc -diagram w xs = Col (map chart (discretize xs')) - where - xs' = replicate (2 * w - length xs) 0 ++ reverse (take (2 * w) xs) - - chart :: (Int, Int) -> Doc - chart n = colorize n (pretty (chart' n)) - - chart' (0, 0) = '⠀' - chart' (0, 1) = '⢀' - chart' (0, 2) = '⢠' - chart' (0, 3) = '⢰' - chart' (0, 4) = '⢸' - chart' (1, 0) = '⡀' - chart' (1, 1) = '⣀' - chart' (1, 2) = '⣠' - chart' (1, 3) = '⣰' - chart' (1, 4) = '⣸' - chart' (2, 0) = '⡄' - chart' (2, 1) = '⣄' - chart' (2, 2) = '⣤' - chart' (2, 3) = '⣴' - chart' (2, 4) = '⣼' - chart' (3, 0) = '⡆' - chart' (3, 1) = '⣆' - chart' (3, 2) = '⣦' - chart' (3, 3) = '⣶' - chart' (3, 4) = '⣾' - chart' (4, 0) = '⡇' - chart' (4, 1) = '⣇' - chart' (4, 2) = '⣧' - chart' (4, 3) = '⣷' - chart' (4, 4) = '⣿' - chart' _ = error "chart': argument >4 (or <0)" - - colorize (n, m) = colorize' (max n m) - - colorize' 0 = colorDull Green - colorize' 1 = color Green - colorize' 2 = colorDull Yellow - colorize' 3 = color Yellow - colorize' 4 = color Red - colorize' _ = error "colorize': argument >4 (or <0)" - - discretize :: [Float] -> [(Int, Int)] - discretize [] = [] - discretize (_ : []) = [] - discretize (x1 : x2 : xs) = - (round (x1 * 4), round (x2 * 4)) : discretize xs +instance Pretty Float where + pretty = pretty . Diagram 1 . (: []) + +data Diagram a = Diagram Int a deriving (Functor, Show) + +diagram :: Int -> a -> Diagram a +diagram = Diagram + +instance Pretty (Diagram [Float]) where + pretty (Diagram ((2 *) -> n) (take n -> xs)) = Col (map chart (discretize xs')) + where + xs' = replicate (n - length xs) 0 ++ xs + + chart :: (Int, Int) -> Doc + chart n = colorize n (pretty (chart' n)) + + chart' (0, 0) = '⠀' + chart' (0, 1) = '⢀' + chart' (0, 2) = '⢠' + chart' (0, 3) = '⢰' + chart' (0, 4) = '⢸' + chart' (1, 0) = '⡀' + chart' (1, 1) = '⣀' + chart' (1, 2) = '⣠' + chart' (1, 3) = '⣰' + chart' (1, 4) = '⣸' + chart' (2, 0) = '⡄' + chart' (2, 1) = '⣄' + chart' (2, 2) = '⣤' + chart' (2, 3) = '⣴' + chart' (2, 4) = '⣼' + chart' (3, 0) = '⡆' + chart' (3, 1) = '⣆' + chart' (3, 2) = '⣦' + chart' (3, 3) = '⣶' + chart' (3, 4) = '⣾' + chart' (4, 0) = '⡇' + chart' (4, 1) = '⣇' + chart' (4, 2) = '⣧' + chart' (4, 3) = '⣷' + chart' (4, 4) = '⣿' + chart' x = error (show x) + + colorize (n, m) = colorize' (max n m) + + colorize' 0 = colorDull Green + colorize' 1 = color Green + colorize' 2 = colorDull Yellow + colorize' 3 = color Yellow + colorize' 4 = color Red + colorize' x = error (show x) + + discretize :: [Float] -> [(Int, Int)] + discretize [] = [] + discretize (_ : []) = [] + discretize (x1 : x2 : xs) = + (round (x1 * 4), round (x2 * 4)) : discretize xs color :: Color -> Doc -> Doc color c = color' (Vivid, c) diff --git a/app/Sensor.hs b/app/Sensor.hs index 7d9324b..55d2554 100644 --- a/app/Sensor.hs +++ b/app/Sensor.hs @@ -1,20 +1,21 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE Arrows #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Sensor - ( SensorM, - runSensorM, - poll, - Sensor (..), - cpu, + ( cpu, io, net, mem, @@ -28,18 +29,21 @@ module Sensor ) where +import Control.Arrow +import Control.DeepSeq import Control.Monad import Control.Monad.Reader import Data.Char import Data.Dynamic import Data.Functor.WithIndex import Data.List -import Data.Map qualified as M import Data.Maybe +import Data.Sensor qualified as S import Data.Set qualified as S import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime +import GHC.Generics (Generic) import Graphics.X11 qualified as X import Graphics.X11.Xlib.Extras qualified as X import Pretty qualified as P @@ -47,494 +51,415 @@ import Process.Shell (sh) import Safe import System.Directory import System.FilePath -import System.IO.Error -import System.Linux.Inotify qualified as I +import System.IO (hGetContents) import System.Posix.StatVFS +import System.Posix.Types (Fd (..)) import Text.Printf +import UnliftIO import UnliftIO.Concurrent -import UnliftIO.Exception -import UnliftIO.Memoize -import UnliftIO.STM import Witherable (ifilter) +import Prelude hiding (readFile) -type SensorM a = - ReaderT (MVar (M.Map String (Memoized Dynamic))) IO a - -runSensorM :: SensorM a -> IO a -runSensorM m = do - g <- newMVar M.empty - runReaderT m g - -poll :: (Typeable a) => Sensor a -> SensorM (TVar a) -poll (Sensor id vM') = do - gM <- ask - g <- takeMVar gM - vM <- case M.lookup id g of - Just vM -> do - putMVar gM g - pure (fromJust . fromDynamic <$> vM) - Nothing -> do - -- liftIO (printf "[%s] start\n" id) - vM <- vM' - putMVar gM (M.insert id (toDyn <$> vM) g) - pure vM - runMemoized vM - -data Sensor a = Sensor String (SensorM (Memoized (TVar a))) - -data CpuStat = CpuStat - { total :: Int, - idle :: Int +data CpuStatData = CpuStatData + { used :: Int, + total :: Int } - deriving (Show, Eq) - -cpuStat :: Sensor CpuStat -cpuStat = pollFile "cpuStat" aggregate "/proc/stat" (5 * 10 ^ 5) - where - aggregate fp = liftIO do - stat <- readFile fp - case filter ("cpu " `isPrefixOf`) (lines stat) of - [] -> error "/proc/stat: no cpu line" - (cpu : _) -> - case map read (drop 1 (words cpu)) of - xs@(_ : _ : _ : idle : _) -> - pure $ CpuStat (sum xs) idle - _ -> error "/proc/stat: unexpected cpu line" - -cpu' :: Sensor [CpuStat] -cpu' = histogram "cpu'" [] (\b a -> take 7 (a : b)) cpuStat - -data Cpu = Cpu {unCpu :: [Float]} - -instance P.Pretty Cpu where - pretty = P.diagram 3 . unCpu - -cpu :: Sensor Cpu -cpu = transform "cpu" f cpu' - where - f xs = do - let xs' = - zipWith - ( \next prev -> - let total = next.total - prev.total - idle = next.idle - prev.idle - in fromIntegral (total - idle) / fromIntegral total - ) - (fromMaybe [] (initMay xs)) - (fromMaybe [] (tailMay xs)) - pure (Cpu xs') - -data IoStat = IoStat {unIoStat :: Int} deriving (Show, Eq) - -ioStat :: Sensor IoStat -ioStat = poll' "ioStat" aggregate (5 * 10 ^ 5) - where - aggregate = liftIO do - fmap (IoStat . sum) . mapM (aggregate' . ("/sys/block" </>)) - =<< listDirectory "/sys/block" - aggregate' fp = do - stat <- readFile (fp </> "stat") - case words stat of - [_, _, read', _, _, _, write', _, _, _, _, _, _, _, _, _, _] -> - pure (read read' + read write') - _ -> error (printf "%s/stat: malformed" fp) - -io' :: Sensor [IoStat] -io' = histogram "io'" [] (\b a -> take 7 (a : b)) ioStat - -data Io = Io {unIo :: [Float]} deriving (Show, Eq) - -instance P.Pretty Io where - pretty = P.diagram 3 . unIo - -io :: Sensor Io -io = transform "io" f io' - where - f (map unIoStat -> xs) = do - let xs' = - zipWith - (-) - (fromMaybe [] (initMay xs)) - (fromMaybe [] (tailMay xs)) - x' = max 1 (fromMaybe 0 (maximumMay xs')) - pure . Io $ - map (\x -> fromIntegral x / fromIntegral x') xs' - -data NetStat = NetStat {unNetStat :: Int} deriving (Show, Eq) - -netStat :: Sensor NetStat -netStat = poll' "netStat" aggregate (5 * 10 ^ 5) - where - aggregate = liftIO do - is <- listDirectory "/sys/class/net" - NetStat . sum <$> mapM (aggregate' . ("/sys/class/net" </>)) is - aggregate' fp = do - (+) - <$> (read <$> readFile (fp </> "statistics/rx_bytes")) - <*> (read <$> readFile (fp </> "statistics/tx_bytes")) - -net' :: Sensor [NetStat] -net' = histogram "net'" [] (\b a -> take 7 (a : b)) netStat - -data Net = Net {unNet :: [Float]} deriving (Show, Eq) - -instance P.Pretty Net where - pretty = P.diagram 3 . unNet - -net :: Sensor Net -net = transform "net" f net' - where - f (map unNetStat -> xs) = do - let xs' = - zipWith - (-) - (fromMaybe [] (initMay xs)) - (fromMaybe [] (tailMay xs)) - x' = max 1 (fromMaybe 0 (maximumMay xs')) - pure $ Net $ map (\x -> fromIntegral x / fromIntegral x') xs' - -data MemStat = MemStat {unMemStat :: Float} deriving (Show, Eq) - -memStat :: Sensor MemStat -memStat = pollFile "memStat" aggregate "/proc/meminfo" (5 * 10 ^ 5) + deriving (Eq, Show, Generic, NFData) + +data CpuStat = CpuStat deriving (Show) + +instance (S.MonadSensor m) => S.Aggregate m CpuStat CpuStatData where + aggregate _ = forever do S.yield =<< parse <* sleep + where + parse = readFile "/proc/stat" $ \stat -> do + case filter (["cpu"] `isPrefixOf`) (words <$> lines stat) of + [] -> error "/proc/stat: no cpu line" + ((drop 1 . fmap read -> (xs@(_ : _ : _ : idle : _))) : _) -> do + let total = sum xs + used = total - idle + pure (CpuStatData used total) + _ -> error "/proc/stat: unexpected cpu line" + +readFile :: (MonadUnliftIO m, NFData a) => FilePath -> (String -> m a) -> m a +readFile fp f = + withFile fp ReadMode $ \h -> + evaluate =<< f =<< (liftIO (hGetContents h)) + +sleep :: (MonadIO m) => S.AggregateT s m () +sleep = threadDelay (5 * 10 ^ 5) + +cpuStat :: (S.MonadSensor m) => S.Sensor m () CpuStatData +cpuStat = S.sensor CpuStat + +cpu :: (S.MonadSensor m) => S.Sensor m () (P.Diagram [Float]) +cpu = step <$$> diagram 3 cpuStat where - aggregate fp = liftIO do - meminfo <- readFile fp - case foldl - ( \(total, avail) xs -> - case xs of - ["MemTotal:", v, "kB"] -> (Just (read v), avail) - ["MemAvailable:", v, "kB"] -> (total, Just (read v)) - _ -> (total, avail) + step xs = + zipWith + ( \next prev -> + let CpuStatData {used, total} = + CpuStatData (next.used - prev.used) (next.total - prev.total) + in if total == 0 then 0 else fromIntegral used / fromIntegral total ) - (Nothing, Nothing) - (map words (lines meminfo)) of - (Just total, Just avail) -> pure $ MemStat (1 - avail / total) - (Nothing, _) -> error (printf "%s: MemTotal missing" fp) - (_, Nothing) -> error (printf "%s: MemAvail missing" fp) - -mem' :: Sensor [MemStat] -mem' = histogram "mem'" [] (\b a -> take 7 (a : b)) memStat - -data Mem = Mem {unMem :: [Float]} deriving (Show, Eq) - -instance P.Pretty Mem where - pretty = P.diagram 3 . unMem - -mem :: Sensor Mem -mem = transform "mem" (\(map unMemStat -> xs) -> pure (Mem xs)) mem' - -data BatStat = BatStat {unBatStat :: Float} deriving (Show, Eq) - -batStat :: Sensor BatStat -batStat = poll' "batStat" aggregate (5 * 10 ^ 5) - where - aggregate = liftIO do - fmap (BatStat . product) . mapM (aggregate' . ("/sys/class/power_supply" </>)) - =<< listDirectory "/sys/class/power_supply" - aggregate' fp = - choice 1 $ - [ (/) - <$> (read <$> readFile (fp </> "charge_now")) - <*> (read <$> readFile (fp </> "charge_full")), - (/) - <$> (read <$> readFile (fp </> "energy_now")) - <*> (read <$> readFile (fp </> "energy_full")) - ] + (fromMaybe [] (tailMay xs)) + (fromMaybe [] (initMay xs)) + +diagram :: (Monad m) => Int -> S.Sensor m () a -> S.Sensor m () (P.Diagram [a]) +diagram n sf = S.feedbackS [] $ proc ((), xs) -> do + x <- sf -< () + returnA -< (P.diagram n (reverse (x : xs)), take (2 * (n - 1) + 1) (x : xs)) + +data IoStat = IoStat deriving (Show) + +instance (S.MonadSensor m) => S.Aggregate m IoStat Int where + aggregate _ = forever do S.yield =<< parse <* sleep + where + parse = liftIO do + fmap sum . mapM (parse1 . ("/sys/block" </>)) + =<< listDirectory "/sys/block" + parse1 :: FilePath -> IO Int + parse1 fp = do + readFile (fp </> "stat") $ \stat -> do + case words stat of + [_, _, read', _, _, _, write, _, _, _, _, _, _, _, _, _, _] -> + pure (read read' + read write) + _ -> error (printf "%s/stat: malformed" fp) + +ioStat :: (S.MonadSensor m) => S.Sensor m () Int +ioStat = S.sensor IoStat + +io :: (S.MonadSensor m) => S.Sensor m () (P.Diagram [Float]) +io = diagram 3 (maxS (rate ioStat)) + +maxS :: (Monad m, Num a, Ord a, Integral a) => S.Sensor m () a -> S.Sensor m () Float +maxS sf = S.feedbackS 0 $ proc ((), xMax) -> do + x <- fi <$> sf -< () + let xMax' = max xMax x + returnA -< (if xMax <= 0 then 0 else x / xMax', xMax') + +rate :: (Monad m, Num a) => S.Sensor m () a -> S.Sensor m () a +rate sf = S.feedbackS 0 $ proc ((), x') -> do + x <- sf -< () + returnA -< (x - x', x) + +data NetStat = NetStat deriving (Show) + +instance (S.MonadSensor m) => S.Aggregate m NetStat Int where + aggregate _ = forever do S.yield =<< parse <* sleep + where + parse = liftIO do + is <- listDirectory "/sys/class/net" + sum <$> mapM (parse1 . ("/sys/class/net" </>)) is + parse1 :: FilePath -> IO Int + parse1 fp = do + (+) + <$> (readFile (fp </> "statistics/rx_bytes") (pure . read)) + <*> (readFile (fp </> "statistics/tx_bytes") (pure . read)) + +netStat :: (S.MonadSensor m) => S.Sensor m () Int +netStat = S.sensor NetStat + +net :: (S.MonadSensor m) => S.Sensor m () (P.Diagram [Float]) +net = diagram 3 (maxS (rate netStat)) + +data MemStat = MemStat deriving (Show) + +instance (S.MonadSensor m) => S.Aggregate m MemStat Float where + aggregate _ = forever do S.yield =<< parse <* sleep + where + parse = readFile "/proc/meminfo" $ \meminfo -> do + case foldl + ( \(total, avail) xs -> + case xs of + ["MemTotal:", v, "kB"] -> (Just (read v), avail) + ["MemAvailable:", v, "kB"] -> (total, Just (read v)) + _ -> (total, avail) + ) + (Nothing, Nothing) + (map words (lines meminfo)) of + (Just total, Just avail) -> pure (1 - avail / total) + (Nothing, _) -> error "/proc/meminfo: MemTotal missing" + (_, Nothing) -> error "/proc/meminfo: MemAvail missing" + +memStat :: (S.MonadSensor m) => S.Sensor m () Float +memStat = S.sensor MemStat + +mem :: (S.MonadSensor m) => S.Sensor m () (P.Diagram [Float]) +mem = diagram 3 memStat + +data BatStat = BatStat deriving (Show) + +instance (S.MonadSensor m) => S.Aggregate m BatStat Float where + aggregate _ = forever do S.yield =<< parse <* sleep + where + parse = liftIO do + fmap product . mapM (parse1 . ("/sys/class/power_supply" </>)) + =<< listDirectory "/sys/class/power_supply" + parse1 :: FilePath -> IO Float + parse1 fp = + choice 1 $ + [ (/) + <$> (readFile (fp </> "charge_now") (pure . read)) + <*> (readFile (fp </> "charge_full") (pure . read)), + (/) + <$> (readFile (fp </> "energy_now") (pure . read)) + <*> (readFile (fp </> "energy_full") (pure . read)) + ] + +bat :: (S.MonadSensor m) => S.Sensor m () Float +bat = S.sensor BatStat choice :: a -> [IO a] -> IO a choice def [] = pure def choice def (x : xs) = x `catch` (\(_ :: SomeException) -> choice def xs) -bat' :: Sensor [BatStat] -bat' = histogram "bat'" [] (\b a -> take 7 (a : b)) batStat - -data Bat = Bat {unBat :: [Float]} deriving (Show, Eq) - -instance P.Pretty Bat where - pretty = P.diagram 1 . unBat - -bat :: Sensor Bat -bat = transform "bat" (\(map unBatStat -> xs) -> pure (Bat xs)) bat' - -data Snd = Snd {unSnd :: Float} deriving (Show, Eq) +data Snd = Snd deriving (Show) -instance P.Pretty Snd where - pretty = P.diagram 1 . (: []) . unSnd +instance (S.MonadSensor m) => S.Aggregate m Snd Float where + aggregate _ = forever do S.yield =<< parse <* sleep + where + parse = liftIO do (/ 153) . read <$> [sh|pamixer --get-volume|] -snd :: Sensor Snd -snd = Sensor "snd" $ memoizeMVar do - stateT <- newTVarIO (Snd 1) - void $ forkIO $ forever do - x <- liftIO aggregate - atomically do writeTVar stateT (Snd x) - threadDelay (2 * 10 ^ 6) - pure stateT - where - aggregate = do - (/ 153) . read <$> [sh|pamixer --get-volume|] - -data Disk = Disk {unDisk :: [Float]} deriving (Show, Eq) - -instance P.Pretty Disk where - pretty = P.diagram 1 . unDisk - -disk :: Sensor Disk -disk = Sensor "disk" $ memoizeMVar do - stateT <- newTVarIO (Disk []) - void $ forkIO $ forever do - x <- liftIO aggregate - atomically do - readTVar stateT >>= \(Disk xs) -> - writeTVar stateT (Disk (x : xs)) - threadDelay (2 * 10 ^ 6) - pure stateT - where - aggregate = do - stat <- statVFS "/" - pure $ - (fromIntegral stat.statVFS_bfree) - / fromIntegral (stat.statVFS_bfree + stat.statVFS_bavail) - -currentTime :: Sensor UTCTime -currentTime = Sensor "currentTime" $ memoizeMVar do - stateT <- newTVarIO =<< liftIO getCurrentTime - void $ forkIO $ forever do - x <- liftIO getCurrentTime - atomically . writeTVar stateT =<< liftIO getCurrentTime - threadDelay (((10 ^ 12) - (fromEnum (utctDayTime x) `mod` (10 ^ 12))) `div` (10 ^ 6)) - pure stateT +snd :: (S.MonadSensor m) => S.Sensor m () Float +snd = S.sensor Snd -data Date = Date {unDate :: String} deriving (Show, Eq) - -instance P.Pretty Date where - pretty = P.color P.White . P.pretty . unDate - -date :: Sensor Date -date = transform "date" f currentTime - where - f x = do - z <- liftIO getCurrentTimeZone - pure . Date . formatTime defaultTimeLocale "%b %e" $ - utcToLocalTime z x +data DiskStat = DiskStat deriving (Show) -data Time = Time {unTime :: String} deriving (Show, Eq) +instance (S.MonadSensor m) => S.Aggregate m DiskStat Float where + aggregate _ = forever do S.yield =<< parse <* sleep + where + parse = liftIO do + stat <- statVFS "/" + pure $ + (fi stat.statVFS_bfree) + / fi (stat.statVFS_bfree + stat.statVFS_bavail) -instance P.Pretty Time where - pretty = P.color P.White . P.pretty . unTime +diskStat :: (S.MonadSensor m) => S.Sensor m () Float +diskStat = S.sensor DiskStat -time :: Sensor Time -time = transform "time" f currentTime - where - f x = do - z <- liftIO getCurrentTimeZone - pure . Time . formatTime defaultTimeLocale "%R" $ - utcToLocalTime z x - -data WmName = WmName {unWmName :: String} deriving (Show, Eq) - -instance P.Pretty WmName where - pretty = P.color P.White . P.pretty . unWmName - -wmName' :: Sensor WmName -wmName' = watchXPropertyChanges "wmName'" as aggregate - where - as = ["_NET_ACTIVE_WINDOW"] - aggregate dpy = liftIO do - let root = X.rootWindowOfScreen (X.defaultScreenOfDisplay dpy) - netActiveWindow <- X.internAtom dpy "_NET_ACTIVE_WINDOW" False - X.getWindowProperty32 dpy netActiveWindow root >>= \case - Just (win : _) -> do - netWmName <- X.internAtom dpy "_NET_WM_NAME" False - fmap (WmName . strip . head) . X.wcTextPropertyToTextList dpy - =<< do - let loop 0 = do - error "failed to read _NET_WM_NAME" - loop n = do - catch - (X.getTextProperty dpy (fromIntegral win) netWmName) - ( \(e :: IOError) -> do - if isUserError e - then threadDelay 1000 >> loop (n - 1) - else throwIO e - ) - loop 16 - _ -> pure (WmName "") - strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace +disk :: (S.MonadSensor m) => S.Sensor m () (P.Diagram [Float]) +disk = diagram 1 diskStat -wmName :: Sensor String -wmName = transform "wmName" (\(WmName x) -> pure x) wmName' +data CurrentTime = CurrentTime deriving (Show) -data WmWorkspaces = WmWorkspaces {unWmWorkspaces :: [Workspace]} - deriving (Show, Eq) +instance (S.MonadSensor m) => S.Aggregate m CurrentTime UTCTime where + aggregate _ = forever do + x <- liftIO getCurrentTime + S.yield =<< liftIO getCurrentTime + threadDelay + (((10 ^ 12) - (fromEnum (utctDayTime x) `mod` (10 ^ 12))) `div` (10 ^ 6)) + +data CurrentTimeZone = CurrentTimeZone deriving (Show) + +instance (S.MonadSensor m) => S.Aggregate m CurrentTimeZone TimeZone where + aggregate _ = forever do + S.yield =<< liftIO getCurrentTimeZone + sleep + +currentTimeZone :: (S.MonadSensor m) => S.Sensor m () TimeZone +currentTimeZone = S.sensor CurrentTimeZone + +currentTime :: (S.MonadSensor m) => S.Sensor m () UTCTime +currentTime = S.sensor CurrentTime + +date :: (S.MonadSensor m) => S.Sensor m () String +date = + ((formatTime defaultTimeLocale "%b %e" .) . utcToLocalTime) + <$> currentTimeZone + <*> currentTime + +time :: (S.MonadSensor m) => S.Sensor m () String +time = + ((formatTime defaultTimeLocale "%R" .) . utcToLocalTime) + <$> currentTimeZone + <*> currentTime + +wmName :: (S.MonadSensor m) => S.Sensor m () String +wmName = activeWindow >>= maybe (pure "") wmNameOf + +data ActiveWindow = ActiveWindow deriving (Show) + +instance (S.MonadSensor m) => S.Aggregate m ActiveWindow (Maybe X.Window) where + aggregate _ = do + bracket + ( liftIO do + dpy <- X.openDisplay "" + let root = X.rootWindowOfScreen (X.defaultScreenOfDisplay dpy) + X.selectInput dpy root X.propertyChangeMask + X.sync dpy False + pure (dpy, root) + ) + (\(dpy, _) -> liftIO (X.closeDisplay dpy)) + ( \(dpy, root) -> do + netActiveWindow <- liftIO (X.internAtom dpy "_NET_ACTIVE_WINDOW" False) + let waitForEvent = do + liftIO (X.pending dpy) >>= \case + 0 -> do + liftIO do threadWaitRead (Fd (X.connectionNumber dpy)) + waitForEvent + _ -> do + e <- + liftIO + ( X.allocaXEvent $ \ev -> do + X.nextEvent dpy ev + X.getEvent ev + ) + when (X.ev_atom e /= netActiveWindow) waitForEvent + + readActiveWindow = do + liftIO (X.getWindowProperty32 dpy netActiveWindow root) >>= \case + Just (0 : _) -> S.yield Nothing + Just (win : _) -> S.yield (Just (fi win)) + _ -> S.yield Nothing + forever do + readActiveWindow + waitForEvent + ) + +activeWindow :: (S.MonadSensor m) => S.Sensor m () (Maybe X.Window) +activeWindow = S.sensor ActiveWindow + +data WmNameOf = WmNameOf X.Window deriving (Show) + +instance (S.MonadSensor m) => S.Aggregate m WmNameOf String where + aggregate (WmNameOf win) = do + bracket + ( liftIO do + dpy <- X.openDisplay "" + X.selectInput dpy win X.propertyChangeMask + X.sync dpy False + pure dpy + ) + (liftIO . X.closeDisplay) + ( \dpy -> do + netWmName <- liftIO (X.internAtom dpy "_NET_WM_NAME" False) + let waitForEvent = do + liftIO (X.pending dpy) >>= \case + 0 -> do + liftIO do threadWaitRead (Fd (X.connectionNumber dpy)) + waitForEvent + _ -> do + e <- + liftIO + ( X.allocaXEvent $ \ev -> do + X.nextEvent dpy ev + X.getEvent ev + ) + when (X.ev_atom e /= netWmName) waitForEvent + + readWmName = do + S.yield + =<< fmap (strip . head) . liftIO . X.wcTextPropertyToTextList dpy + =<< liftIO (X.getTextProperty dpy win netWmName) + forever do + readWmName + waitForEvent + ) + +wmNameOf :: (S.MonadSensor m) => X.Window -> S.Sensor m () String +wmNameOf = S.sensor . WmNameOf + +data WmWorkspaces = WmWorkspaces deriving (Show) data Workspace = Active String | Inactive String - deriving (Show, Eq) + deriving (Eq, Typeable, Show) + +instance (S.MonadSensor m) => S.Aggregate m WmWorkspaces [Workspace] where + aggregate WmWorkspaces = do + bracket + ( liftIO do + dpy <- X.openDisplay "" + let root = X.rootWindowOfScreen (X.defaultScreenOfDisplay dpy) + X.selectInput dpy root X.propertyChangeMask + X.sync dpy False + pure (dpy, root) + ) + (\(dpy, _) -> liftIO (X.closeDisplay dpy)) + ( \(dpy, root) -> do + netClientList <- liftIO $ X.internAtom dpy "_NET_CLIENT_LIST" False + netCurrentDesktop <- liftIO $ X.internAtom dpy "_NET_CURRENT_DESKTOP" False + netDesktopNames <- liftIO $ X.internAtom dpy "_NET_DESKTOP_NAMES" False + netWmDesktop <- liftIO $ X.internAtom dpy "_NET_WM_DESKTOP" False + let waitForEvent = do + liftIO (X.pending dpy) >>= \case + 0 -> do + liftIO (threadWaitRead (Fd (X.connectionNumber dpy))) + waitForEvent + _ -> do + e <- + liftIO + ( X.allocaXEvent $ \ev -> do + X.nextEvent dpy ev + X.getEvent ev + ) + when + ( ((not .) . elem) + (X.ev_atom e) + [ netClientList, + netCurrentDesktop, + netDesktopNames, + netWmDesktop + ] + ) + waitForEvent + + readWmWorkspaces = do + S.yield + =<< liftIO do + currentDesktop <- + fmap (fi . head) + <$> X.getWindowProperty32 dpy netCurrentDesktop root + occupiedDesktops <- + fmap (S.unions . catMaybes) + . mapM + ( \win -> do + fmap (S.singleton . fi . head) + <$> X.getWindowProperty32 dpy netWmDesktop win + ) + . map fi + . fromMaybe [] + =<< X.getWindowProperty32 dpy netClientList root + fmap + ( ifilter + ( \i _ -> + Just i == currentDesktop + || i `S.member` occupiedDesktops + ) + . imap + ( \i -> + if Just i == currentDesktop + then Active + else Inactive + ) + ) + . X.wcTextPropertyToTextList dpy + =<< X.getTextProperty dpy root netDesktopNames + forever do + readWmWorkspaces + waitForEvent + ) + +wmWorkspaces :: (S.MonadSensor m) => S.Sensor m () [Workspace] +wmWorkspaces = S.sensor WmWorkspaces -instance P.Pretty WmWorkspaces where +instance P.Pretty [Workspace] where pretty = - P.Col . intersperse (P.pretty " ") . map P.pretty . unWmWorkspaces + P.Col . intersperse (P.pretty " ") . map P.pretty instance P.Pretty Workspace where pretty (Active s) = P.color P.White (P.pretty s) pretty (Inactive s) = P.colorDull P.White (P.pretty s) -wmWorkspaces :: Sensor WmWorkspaces -wmWorkspaces = watchXPropertyChanges "wmWorkspaces" as aggregate - where - as = - [ "_NET_CLIENT_LIST", - "_NET_CURRENT_DESKTOP", - "_NET_DESKTOP_NAMES", - "_NET_WM_DESKTOP" - ] - aggregate dpy = liftIO do - let root = X.rootWindowOfScreen (X.defaultScreenOfDisplay dpy) - netClientList <- liftIO $ X.internAtom dpy "_NET_CLIENT_LIST" False - netCurrentDesktop <- liftIO $ X.internAtom dpy "_NET_CURRENT_DESKTOP" False - netDesktopNames <- liftIO $ X.internAtom dpy "_NET_DESKTOP_NAMES" False - netWmDesktop <- liftIO $ X.internAtom dpy "_NET_WM_DESKTOP" False - currentDesktop <- fmap (fromIntegral . head) <$> X.getWindowProperty32 dpy netCurrentDesktop root - occupiedDesktops <- - fmap (S.unions . catMaybes) - . mapM - ( \win -> do - fmap (S.singleton . fromIntegral . head) - <$> X.getWindowProperty32 dpy netWmDesktop win - ) - . map fromIntegral - . fromMaybe [] - =<< X.getWindowProperty32 dpy netClientList root - fmap - ( WmWorkspaces - . ifilter (\i _ -> Just i == currentDesktop || i `S.member` occupiedDesktops) - . imap - ( \i -> - if Just i == currentDesktop - then Active - else Inactive - ) - ) - . X.wcTextPropertyToTextList dpy - =<< X.getTextProperty dpy root netDesktopNames - -watchFile :: String -> (FilePath -> SensorM a) -> FilePath -> Sensor a -watchFile id aggregate fp = Sensor id $ memoizeMVar do - i <- liftIO do - i <- I.init - void (I.addWatch i fp I.in_CLOSE) - pure i - stateT <- newTVarIO =<< aggregate fp - void $ forkIO $ forever do - void (liftIO (I.getEvent i)) - -- liftIO (printf "[%s] aggregate\n" id) - x <- aggregate fp - atomically (writeTVar stateT x) - pure stateT - -pollFile :: String -> (FilePath -> SensorM a) -> FilePath -> Int -> Sensor a -pollFile id aggregate fp delay = Sensor id $ memoizeMVar do - stateT <- newTVarIO =<< aggregate fp - void $ forkIO $ forever do - -- liftIO (printf "[%s] aggregate\n" id) - x <- aggregate fp - threadDelay delay - atomically (writeTVar stateT x) - pure stateT - -poll' :: String -> SensorM a -> Int -> Sensor a -poll' id aggregate delay = Sensor id $ memoizeMVar do - stateT <- newTVarIO =<< aggregate - void $ forkIO $ forever do - -- liftIO (printf "[%s] aggregate\n" id) - x <- aggregate - threadDelay delay - atomically (writeTVar stateT x) - pure stateT - -watchXPropertyChanges :: - String -> - [String] -> - (X.Display -> SensorM a) -> - Sensor a -watchXPropertyChanges id as' aggregate = Sensor id $ memoizeMVar do - (dpy, as) <- liftIO do - dpy <- X.openDisplay "" - let root = X.rootWindowOfScreen (X.defaultScreenOfDisplay dpy) - X.selectInput dpy root X.propertyChangeMask - as <- S.fromList <$> mapM (\a -> X.internAtom dpy a False) as' - pure (dpy, as) - stateT <- newTVarIO =<< aggregate dpy - void $ forkIO $ forever $ do - as' <- liftIO $ X.allocaXEvent $ \ev -> do - X.nextEvent dpy ev - e <- X.getEvent ev - let loop es = do - isTimeout <- X.waitForEvent dpy 0 - if isTimeout - then pure (S.fromList (map (X.ev_atom) es)) - else do - X.nextEvent dpy ev - e <- X.getEvent ev - loop (e : es) - loop [e] - unless (S.null (as `S.intersection` as')) do - atomically . writeTVar stateT =<< aggregate dpy - pure stateT - -histogram :: - (Eq a, Typeable a) => - String -> - b -> - (b -> a -> b) -> - Sensor a -> - Sensor b -histogram id def acc sensor = transform' id def f sensor - where - f b a = pure (acc b a) - -transform' :: - (Eq a, Typeable a) => - String -> - b -> - (b -> a -> SensorM b) -> - Sensor a -> - Sensor b -transform' id def fM sensor = Sensor id $ memoizeMVar do - xT <- poll sensor - x <- readTVarIO xT - x'T <- newTVarIO x - stateT <- newTVarIO =<< fM def x - void $ forkIO $ forever $ do - (def, x) <- atomically do - x' <- readTVar x'T - x <- readTVar xT - checkSTM (x /= x') - def <- readTVar stateT - writeTVar x'T x - pure (def, x) - atomically . writeTVar stateT =<< fM def x - pure stateT - -transform :: - (Eq a, Typeable a) => - String -> - (a -> SensorM b) -> - Sensor a -> - Sensor b -transform id fM sensor = Sensor id $ memoizeMVar do - xT <- poll sensor - x <- readTVarIO xT - x'T <- newTVarIO x - stateT <- newTVarIO =<< fM x - void $ forkIO $ forever $ do - x <- atomically do - x' <- readTVar x'T - x <- readTVar xT - checkSTM (x /= x') - writeTVar x'T x - pure x - atomically . writeTVar stateT =<< fM x - pure stateT +(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +f <$$> x = fmap f <$> x + +infixl 4 <$$> + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +strip :: String -> String +strip = + reverse . dropWhile isSpace . reverse . dropWhile isSpace @@ -11,10 +11,9 @@ module Ui ( Ui (Ui), + Block, lit, fill, - sens, - initUi, pollUi, Env (..), Ui', @@ -24,72 +23,40 @@ module Ui ) where -import Control.Concurrent.STM -import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State (evalStateT, get, modify) import Data.Default -import Data.Dynamic import Data.Map qualified as M import Data.Maybe +import Data.Sensor qualified as S import GHC.Generics (Generic) import Graphics.X11 qualified as X import Graphics.X11.Xft qualified as X import Graphics.X11.Xrender qualified as X import Pretty qualified as P -import Sensor hiding (io) -data Ui f a = Ui [Block f a] +data Ui a = Ui [a] deriving (Eq, Functor, Foldable, Traversable, Show) -instance Eq (Ui Identity P.Doc) where - Ui bs == Ui bs' = bs == bs' - -data Block f a - = Lit P.Doc +data Block a + = Lit a | Fill - | forall o. (Typeable o) => Sens (o -> a) (f o) - -instance Eq (Block Identity P.Doc) where - (Lit doc) == (Lit doc') = doc == doc' - Fill == Fill = True - Sens toOut (Identity x) == Sens toOut' (Identity x') = toOut x == toOut' x' - _ == _ = False + deriving (Eq, Functor, Show) -lit :: (P.Pretty a) => a -> Block f P.Doc +lit :: (P.Pretty a) => a -> Block P.Doc lit = Lit . P.pretty -fill :: Block f a +fill :: Block a fill = Fill -sens :: (P.Pretty o, Typeable o) => f o -> Block f P.Doc -sens = Sens P.pretty - -initUi :: - Ui Sensor P.Doc -> - SensorM (Ui TVar P.Doc) -initUi (Ui bs) = Ui <$> mapM go bs - where - go (Lit s) = pure (Lit s) - go Fill = pure Fill - go (Sens toOut s) = Sens toOut <$> poll s - pollUi :: - Ui TVar P.Doc -> - STM (Ui Identity P.Doc) -pollUi (Ui bs) = Ui <$> mapM go bs - where - go (Lit s) = pure (Lit s) - go Fill = pure Fill - go (Sens toOut vT) = Sens toOut . Identity <$> readTVar vT - -layOutUi :: - Env -> - Ui Identity P.Doc -> - IO Ui' + Ui (S.Sensor (S.SensorT IO) () (Block P.Doc)) -> + S.Sensor (S.SensorT IO) () (Ui (Block P.Doc)) +pollUi = sequence + +layOutUi :: Env -> Ui (Block P.Doc) -> IO Ui' layOutUi env (Ui bs) = layOut env (Ui' (concatMap go bs)) where go (Lit doc) = go' doc - go (Sens toOut (runIdentity -> toOut -> doc)) = go' doc go Fill = [ C { rect = def, |