diff options
Diffstat (limited to 'app/Sensor.hs')
| -rw-r--r-- | app/Sensor.hs | 855 |
1 files changed, 390 insertions, 465 deletions
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 |