summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--app/Main.hs12
-rw-r--r--app/Pretty/Color.hs8
-rw-r--r--app/Sensor.hs837
-rw-r--r--app/Ui.hs26
-rw-r--r--astatusbar.cabal3
-rw-r--r--default.nix3
-rw-r--r--nix/sources.json10
7 files changed, 449 insertions, 450 deletions
diff --git a/app/Main.hs b/app/Main.hs
index 3b41690..573e6a1 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -8,6 +8,7 @@
module Main where
+import Control.Arrow
import Control.Concurrent
import Control.Exception
import Control.Monad
@@ -63,7 +64,7 @@ type Colors = M.Map (P.Intensity, P.Color) X.XftColor
data State = State
{ dirty :: Bool,
- ui :: Ui (S.Sensor (S.SensorT IO) () (Block P.Doc))
+ ui :: Ui (S.Sensor () (Block P.Doc))
}
main :: IO ()
@@ -76,7 +77,8 @@ run :: Env -> TVar State -> Colors -> IO ()
run env stateT colors = do
-- 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
+ state <- atomically $ readTVar stateT
+ S.reactimateS (pollUi state.ui >>> S.arrS (go Nothing))
where
go Nothing pUi = do
atomically do
@@ -181,8 +183,7 @@ createWindow args = do
drw <- X.xftDrawCreate dpy pixm vis cmap
X.mapWindow dpy win
let dirty = True
- let ui :: Ui (S.Sensor (S.SensorT IO) () (Block P.Doc))
- ui =
+ let ui =
Ui $
intercalate [pure (lit " ")] $
[ [lit <$> wmWorkspaces],
@@ -196,8 +197,7 @@ createWindow args = do
[pure (lit " "), lit <$> thermal],
[pure (lit " "), lit <$> bat],
[lit <$> weatherForecast],
- [pure (lit " "), lit <$> date, pure (lit ", "), lit <$> time],
- []
+ [pure (lit " "), lit <$> date, pure (lit ", "), lit <$> time]
]
xcolors <- do
X.rmInitialize
diff --git a/app/Pretty/Color.hs b/app/Pretty/Color.hs
index 7a55909..5ea5347 100644
--- a/app/Pretty/Color.hs
+++ b/app/Pretty/Color.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Pretty.Color
@@ -8,6 +9,9 @@ module Pretty.Color
)
where
+import Control.DeepSeq (NFData)
+import GHC.Generics (Generic)
+
data Color
= Black
| Red
@@ -17,7 +21,7 @@ data Color
| Magenta
| Cyan
| White
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic, NFData)
toXColor :: (Intensity, Color) -> XColor
toXColor (Dull, Black) = Color0
@@ -38,7 +42,7 @@ toXColor (Vivid, Cyan) = Color14
toXColor (Vivid, White) = Color15
data Intensity = Vivid | Dull
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic, NFData)
data XColor
= Color0
diff --git a/app/Sensor.hs b/app/Sensor.hs
index 165a1ae..2c2e860 100644
--- a/app/Sensor.hs
+++ b/app/Sensor.hs
@@ -16,6 +16,7 @@
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+{-# OPTIONS_GHC -fno-warn-x-partial #-}
module Sensor
( cpu,
@@ -74,32 +75,28 @@ data CpuStatData = CpuStatData
}
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 :: (MonadIO m) => 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])
+cpuStat :: S.Sensor () CpuStatData
+cpuStat = S.sensor (\() -> "cpuStat") $ \() yield -> forever do
+ 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"
+
+cpu :: S.Sensor () (P.Diagram [Float])
cpu = step <$$> diagram 3 cpuStat
where
step xs =
@@ -112,106 +109,88 @@ cpu = step <$$> diagram 3 cpuStat
(fromMaybe [] (tailMay xs))
(fromMaybe [] (initMay xs))
-diagram :: (Monad m) => Int -> S.Sensor m () a -> S.Sensor m () (P.Diagram [a])
+diagram :: Int -> S.Sensor () a -> S.Sensor () (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 Thermal = Thermal deriving (Show)
-
-instance (S.MonadSensor m) => S.Aggregate m Thermal Int where
- aggregate _ = forever do S.yield =<< parse <* sleep
- where
- parse = liftIO do
- is <- listDirectory "/sys/class/thermal"
- maximum <$> mapM (parse1 . ("/sys/class/thermal" </>)) is
- parse1 fp = do
- (choice 0 [readFile (fp </> "temp") (pure . read . strip)])
-
-thermal :: (S.MonadSensor m) => S.Sensor m () String
-thermal = do
- temp <- S.sensor Thermal
- pure (printf "%.1f" (value temp))
+thermal :: S.Sensor () String
+thermal = S.sensor (\() -> "thermal") $ \() yield -> forever do
+ yield . fmt =<< parse <* sleep
+ where
+ parse = liftIO do
+ is <- listDirectory "/sys/class/thermal"
+ maximum <$> mapM (parse1 . ("/sys/class/thermal" </>)) is
+ parse1 fp = do
+ (choice 0 [readFile (fp </> "temp") (pure . read @Int . strip)])
+ fmt temp = (printf "%.1f" (fromIntegral temp / (1000 :: Float)))
+
+ioStat :: S.Sensor () Int
+ioStat = S.sensor (\() -> "ioStat") $ \() yield -> forever do
+ yield =<< parse <* sleep
where
- value :: Int -> Float
- value temp = fromIntegral temp / 1000.0
-
-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])
+ 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)
+
+io :: S.Sensor () (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 :: (Ord b, Integral a, Fractional b) => S.Sensor () a -> S.Sensor () b
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 :: (Num a) => S.Sensor () a -> S.Sensor () a
rate sf = S.feedbackS Nothing $ proc ((), x') -> do
x <- sf -< ()
returnA -< (maybe 0 ((-) x) x', Just 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])
+netStat :: S.Sensor () Int
+netStat = S.sensor (\() -> "netStat") $ \() yield -> forever do
+ 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))
+
+net :: S.Sensor () (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
+memStat :: S.Sensor () Float
+memStat = S.sensor (\() -> "memStat") $ \() yield -> forever do
+ 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"
-mem :: (S.MonadSensor m) => S.Sensor m () (P.Diagram [Float])
+mem :: S.Sensor () (P.Diagram [Float])
mem = diagram 3 memStat
data BatStat = BatStat deriving (Show)
@@ -226,29 +205,29 @@ data BatType
= Mains
| Bat
| USB
- deriving (Generic, Eq, NFData)
-
-instance (S.MonadSensor m) => S.Aggregate m BatStat [(Float, BatState, BatType)] where
- aggregate _ = forever do S.yield =<< parse <* sleep
- where
- parse = liftIO do
- mapM (parse1 . ("/sys/class/power_supply" </>))
- =<< listDirectory "/sys/class/power_supply"
- parse1 :: FilePath -> IO (Float, BatState, BatType)
- parse1 fp =
- liftM3
- (,,)
- ( 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))
- ]
- )
- (choice NotCharging [readFile (fp </> "status") (pure . parseBatState . map toLower)])
- (choice Mains [readFile (fp </> "type") (pure . parseBatType . map toLower)])
+ deriving (Show, Generic, Eq, NFData)
+
+batStat :: S.Sensor () [(Float, BatState, BatType)]
+batStat = S.sensor (\() -> "batStat") $ \() yield -> forever do yield =<< parse <* sleep
+ where
+ parse = liftIO do
+ mapM (parse1 . ("/sys/class/power_supply" </>))
+ =<< listDirectory "/sys/class/power_supply"
+ parse1 :: FilePath -> IO (Float, BatState, BatType)
+ parse1 fp =
+ liftM3
+ (,,)
+ ( 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))
+ ]
+ )
+ (choice NotCharging [readFile (fp </> "status") (pure . parseBatState . map toLower)])
+ (choice Mains [readFile (fp </> "type") (pure . parseBatType . map toLower)])
parseBatState :: String -> BatState
parseBatState string =
@@ -266,22 +245,28 @@ parseBatType string =
"usb" -> USB
_ -> error ("invalid bat type: " ++ string)
-bat :: (S.MonadSensor m) => S.Sensor m () P.Doc
-bat = do
- bats <- S.sensor BatStat
- fmap mconcat $ sequence $ intersperse (pure (P.pretty " ")) $ map printBat $ filter isBat bats
+bat :: S.Sensor () P.Doc
+bat = proc () -> do
+ bats <- batStat -< ()
+ isOn <- blink -< ()
+ returnA
+ -<
+ mconcat
+ . intersperse (P.pretty " ")
+ . map (printBat isOn)
+ . filter isBat
+ $ bats
where
isBat (_, _, batType) =
batType == Bat
- printBat :: (S.MonadSensor m) => (Float, BatState, BatType) -> S.Sensor m () P.Doc
- printBat (value, batState, _) =
+ printBat isOn (value, batState, _) =
case batState of
NotCharging ->
- pure (printBatNotCharging value)
+ printBatNotCharging value
Charging ->
- pure (printBatCharging value)
+ printBatCharging value
Discharging ->
- printBatDischarging value
+ printBatDischarging isOn value
printBatNotCharging :: Float -> P.Doc
printBatNotCharging value =
@@ -297,17 +282,14 @@ printBatCharging value =
nfOctArrowUp
]
-printBatDischarging :: (S.MonadSensor m) => Float -> S.Sensor m () P.Doc
-printBatDischarging value =
+printBatDischarging :: Bool -> Float -> P.Doc
+printBatDischarging isOn value =
if value < 0.1
then
- ( \b ->
- if b
- then mconcat [printBatCapacity value, nfOctArrowDown]
- else (P.color P.Red) (mconcat [P.pretty "\xf0083", nfOctArrowDown])
- )
- <$> blink
- else pure (mconcat [printBatCapacity value, nfOctArrowDown])
+ if isOn
+ then mconcat [printBatCapacity value, nfOctArrowDown]
+ else (P.color P.Red) (mconcat [P.pretty "\xf0083", nfOctArrowDown])
+ else (mconcat [printBatCapacity value, nfOctArrowDown])
printBatCapacity :: Float -> P.Doc
printBatCapacity value =
@@ -333,15 +315,10 @@ nfOctArrowDown :: P.Doc
nfOctArrowDown =
P.pretty "\xf433 "
-data Blink = Blink deriving (Show)
-
-blink :: (S.MonadSensor m) => S.Sensor m () Bool
-blink = S.sensor Blink
-
-instance (S.MonadSensor m) => S.Aggregate m Blink Bool where
- aggregate _ = loop True
- where
- loop b = S.yield b >> sleep >> loop (not b)
+blink :: S.Sensor () Bool
+blink = S.sensor (\() -> "blink") (\() yield -> loop yield True)
+ where
+ loop yield b = yield b >> sleep >> loop yield (not b)
choice :: a -> [IO a] -> IO a
choice def [] = pure def
@@ -349,40 +326,38 @@ choice def (x : xs) = x `catch` (\(_ :: SomeException) -> choice def xs)
data Snd = Snd deriving (Show)
-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 :: (S.MonadSensor m) => S.Sensor m () String
-snd = do
- value <- S.sensor Snd
- return
- ( if
- | 0.4 < value -> "\xf028"
- | 0.0 < value -> "\xf027"
- | otherwise -> "\xf026"
+snd :: S.Sensor () String
+snd =
+ (S.sensor (\() -> "snd"))
+ ( \() yield -> forever do
+ ( \value ->
+ yield
+ ( if
+ | 0.4 < value -> "\xf028"
+ | 0.0 < value -> "\xf027"
+ | otherwise -> "\xf026"
+ )
+ )
+ =<< parse <* sleep
)
+ where
+ parse = (/ 153) . read <$> [sh|pamixer --get-volume|]
-data DiskStat = DiskStat deriving (Show)
-
-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)
-
-diskStat :: (S.MonadSensor m) => S.Sensor m () Float
-diskStat = S.sensor DiskStat
+diskStat :: S.Sensor () Float
+diskStat =
+ S.sensor
+ (\() -> "diskStat")
+ (\() yield -> forever do yield =<< parse <* sleep)
+ where
+ parse = liftIO do
+ stat <- statVFS "/"
+ pure $
+ (fi stat.statVFS_bfree)
+ / fi (stat.statVFS_bfree + stat.statVFS_bavail)
-disk :: (S.MonadSensor m) => S.Sensor m () (P.Diagram [Float])
+disk :: S.Sensor () (P.Diagram [Float])
disk = diagram 1 diskStat
-data WeatherForecast = WeatherForecast LocationData deriving (Show)
-
data Forecast = Forecast
{ properties :: ForecastProperties
}
@@ -406,7 +381,7 @@ data ForecastData = ForecastData
{ next_6_hours :: Maybe Next6Hours,
instant :: Instant
}
- deriving (Generic)
+ deriving (Show, Generic)
instance FromJSON ForecastData
@@ -414,14 +389,14 @@ data Next6Hours = Next6Hours
{ summary :: Summary,
details :: Details
}
- deriving (Generic)
+ deriving (Show, Generic)
instance FromJSON Next6Hours
data Summary = Summary
{ symbol_code :: String
}
- deriving (Generic)
+ deriving (Show, Generic)
instance FromJSON Summary
@@ -430,21 +405,21 @@ data Details = Details
air_temperature_min :: Float,
precipitation_amount :: Float
}
- deriving (Generic)
+ deriving (Show, Generic)
instance FromJSON Details
data Instant = Instant
{ details :: InstantDetails
}
- deriving (Generic)
+ deriving (Show, Generic)
instance FromJSON Instant
data InstantDetails = InstantDetails
{ air_temperature :: Float
}
- deriving (Generic)
+ deriving (Show, Generic)
instance FromJSON InstantDetails
@@ -452,216 +427,223 @@ instance FromJSON ForecastTimeserie where
parseJSON value =
fmap ForecastTimeserie (withObject "ForecastTimeserie" (\v -> v .: fromString "data") value)
-instance (S.MonadSensor m) => S.Aggregate m WeatherForecast ForecastData where
- aggregate (WeatherForecast location) = forever do
- forecast <- liftIO (getForecast location)
- S.yield (head forecast.properties.timeseries).data_
- threadDelay ((5 * 60) * 10 ^ 6)
+weatherForecast' :: S.Sensor Location ForecastData
+weatherForecast' =
+ S.sensor
+ (\loc -> printf "weatherForecast %s %s" (show loc.latitude) (show loc.longitude))
+ ( \loc yield -> forever do
+ forecast <- liftIO (getForecast loc)
+ yield (head forecast.properties.timeseries).data_
+ threadDelay ((5 * 60) * 10 ^ 6)
+ )
-getForecast :: LocationData -> IO Forecast
-getForecast LocationData {..} = do
+getForecast :: Location -> IO Forecast
+getForecast Location {..} = do
fmap getResponseBody . httpJSON . addUserAgent . fromString $
printf "https://api.met.no/weatherapi/locationforecast/2.0/complete?lat=%f&lon=%f" latitude longitude
where
addUserAgent req = addRequestHeader (fromString "user-agent") (fromString "astatusbar") req
-weatherForecast :: (S.MonadSensor m) => S.Sensor m () P.Doc
-weatherForecast = do
- forecastData <- S.sensor . WeatherForecast =<< location
+weatherForecast :: S.Sensor () P.Doc
+weatherForecast = proc () -> do
+ loc <- currentLocation -< ()
+ forecastData <- weatherForecast' -< loc
let airTemperature = P.pretty (show forecastData.instant.details.air_temperature)
- pure
- ( case forecastData.next_6_hours of
- Nothing ->
- airTemperature
- Just (Next6Hours {summary, details}) ->
- mconcat $ intersperse (P.pretty " ") [mconcat [symbol, P.pretty " "], tempMax, tempMin, airTemperature]
- where
- symbol =
- P.pretty
- ( case summary.symbol_code of
- -- sunny
- "clearsky_day" -> nfMdWeatherSunny
- "clearsky_night" -> nfMdWeatherSunny
- "clearsky_polartwilight" -> nfMdWeatherSunny
- -- cloudy
- "cloudy" -> nfMdWeatherCloudy
- -- partly cloudy
- "fair_day" -> nfMdWeatherPartlyCloudy
- "fair_night" -> nfMdWeatherPartlyCloudy
- "fair_polartwilight" -> nfMdWeatherPartlyCloudy
- "partlycloudy_day" -> nfMdWeatherPartlyCloudy
- "partlycloudy_night" -> nfMdWeatherPartlyCloudy
- "partlycloudy_polartwilight" -> nfMdWeatherPartlyCloudy
- -- fog
- "fog" -> nfMdWeatherFog
- -- rain
- "rain" -> nfMdWeatherRainy
- "lightrain" -> nfMdWeatherRainy
- "heavyrain" -> nfMdWeatherPouring
- -- snow
- "snow" -> nfMdWeatherSnowy
- "lightsnow" -> nfMdWeatherSnowy
- "heavysnow" -> nfMdWeatherSnowyHeavy
- -- sleet
- "sleet" -> nfMdWeatherHail
- "lightsleet" -> nfMdWeatherSnowyRainy
- "heavysleet" -> nfMdWeatherHail
- -- thunder
- -- rain + thunder
- "rainandthunder" -> nfMdWeatherLightning
- "lightrainandthunder" -> nfMdWeatherLightning
- "heavyrainandthunder" -> nfMdWeatherLightning
- -- sleet + thunder
- "sleetandthunder" -> nfMdWeatherLightning
- "lightsleetandthunder" -> nfMdWeatherLightning
- "heavysleetandthunder" -> nfMdWeatherLightning
- -- snow + thunder
- "snowandthunder" -> nfMdWeatherLightning
- "lightsnowandthunder" -> nfMdWeatherLightning
- "heavysnowandthunder" -> nfMdWeatherLightning
- -- SHOWERS, map to "partly"
- -- rain
- "rainshowers_day" -> nfMdWeatherPartlyRainy
- "rainshowers_night" -> nfMdWeatherPartlyRainy
- "rainshowers_polartwilight" -> nfMdWeatherPartlyRainy
- "lightrainshowers_day" -> nfMdWeatherPartlyRainy
- "lightrainshowers_night" -> nfMdWeatherPartlyRainy
- "lightrainshowers_polartwilight" -> nfMdWeatherPartlyRainy
- "heavyrainshowers_day" -> nfMdWeatherPartlyRainy
- "heavyrainshowers_night" -> nfMdWeatherPartlyRainy
- "heavyrainshowers_polartwilight" -> nfMdWeatherPartlyRainy
- -- snow
- "snowshowers_day" -> nfMdWeatherPartlySnowy
- "snowshowers_night" -> nfMdWeatherPartlySnowy
- "snowshowers_polartwilight" -> nfMdWeatherPartlySnowy
- "lightsnowshowers_day" -> nfMdWeatherPartlySnowy
- "lightsnowshowers_night" -> nfMdWeatherPartlySnowy
- "lightsnowshowers_polartwilight" -> nfMdWeatherPartlySnowy
- "heavysnowshowers_day" -> nfMdWeatherPartlySnowy
- "heavysnowshowers_night" -> nfMdWeatherPartlySnowy
- "heavysnowshowers_polartwilight" -> nfMdWeatherPartlySnowy
- -- sleet
- "sleetshowers_day" -> nfMdWeatherPartlySnowyRainy
- "sleetshowers_night" -> nfMdWeatherPartlySnowyRainy
- "sleetshowers_polartwilight" -> nfMdWeatherPartlySnowyRainy
- "heavysleetshowers_day" -> nfMdWeatherPartlySnowyRainy
- "heavysleetshowers_night" -> nfMdWeatherPartlySnowyRainy
- "heavysleetshowers_polartwilight" -> nfMdWeatherPartlySnowyRainy
- "lightsleetshowers_day" -> nfMdWeatherPartlySnowyRainy
- "lightsleetshowers_night" -> nfMdWeatherPartlySnowyRainy
- "lightsleetshowers_polartwilight" -> nfMdWeatherPartlySnowyRainy
- -- thunder
- -- rain + thunder
- "rainshowersandthunder_day" -> nfMdWeatherPartlyLightning
- "rainshowersandthunder_night" -> nfMdWeatherPartlyLightning
- "rainshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
- "lightrainshowersandthunder_day" -> nfMdWeatherPartlyLightning
- "lightrainshowersandthunder_night" -> nfMdWeatherPartlyLightning
- "lightrainshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
- "heavyrainshowersandthunder_day" -> nfMdWeatherPartlyLightning
- "heavyrainshowersandthunder_night" -> nfMdWeatherPartlyLightning
- "heavyrainshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
- -- snow + thunder
- "snowshowersandthunder_day" -> nfMdWeatherPartlyLightning
- "snowshowersandthunder_night" -> nfMdWeatherPartlyLightning
- "snowshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
- "lightssnowshowersandthunder_day" -> nfMdWeatherPartlyLightning
- "lightssnowshowersandthunder_night" -> nfMdWeatherPartlyLightning
- "lightssnowshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
- "heavysnowshowersandthunder_day" -> nfMdWeatherPartlyLightning
- "heavysnowshowersandthunder_night" -> nfMdWeatherPartlyLightning
- "heavysnowshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
- -- sleet + thunder
- "sleetshowersandthunder_day" -> nfMdWeatherPartlyLightning
- "sleetshowersandthunder_night" -> nfMdWeatherPartlyLightning
- "sleetshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
- "lightssleetshowersandthunder_day" -> nfMdWeatherPartlyLightning
- "lightssleetshowersandthunder_night" -> nfMdWeatherPartlyLightning
- "lightssleetshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
- "heavysleetshowersandthunder_day" -> nfMdWeatherPartlyLightning
- "heavysleetshowersandthunder_night" -> nfMdWeatherPartlyLightning
- "heavysleetshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
- _ -> summary.symbol_code
- )
- tempMax = P.color P.Red (P.pretty (show details.air_temperature_max))
- tempMin = P.colorDull P.Green (P.pretty (show details.air_temperature_min))
-
- nfMdWeatherCloudy = "\xf0590"
- nfMdWeatherFog = "\xf0591"
- nfMdWeatherHail = "\xf0592"
- nfMdWeatherLightning = "\xf0593"
- nfMdWeatherPartlyCloudy = "\xf0595"
- nfMdWeatherPartlyLightning = "\xf0f32"
- nfMdWeatherPartlyRainy = "\xf0f33"
- nfMdWeatherPartlySnowyRainy = "\xf0f35"
- nfMdWeatherPartlySnowy = "\xf0f34"
- nfMdWeatherPouring = "\xf0596"
- nfMdWeatherRainy = "\xf0597"
- nfMdWeatherSnowyHeavy = "\xf0f36"
- nfMdWeatherSnowyRainy = "\xf067f"
- nfMdWeatherSnowy = "\xf0598"
- nfMdWeatherSunny = "\xf0599"
- )
-
-data Location = Location deriving (Show)
-
-location :: (S.MonadSensor m) => S.Sensor m () LocationData
-location = S.sensor Location
+ returnA
+ -<
+ ( case forecastData.next_6_hours of
+ Nothing ->
+ airTemperature
+ Just (Next6Hours {summary, details}) ->
+ mconcat $ intersperse (P.pretty " ") [mconcat [symbol, P.pretty " "], tempMax, tempMin, airTemperature]
+ where
+ symbol =
+ P.pretty
+ ( case summary.symbol_code of
+ -- sunny
+ "clearsky_day" -> nfMdWeatherSunny
+ "clearsky_night" -> nfMdWeatherSunny
+ "clearsky_polartwilight" -> nfMdWeatherSunny
+ -- cloudy
+ "cloudy" -> nfMdWeatherCloudy
+ -- partly cloudy
+ "fair_day" -> nfMdWeatherPartlyCloudy
+ "fair_night" -> nfMdWeatherPartlyCloudy
+ "fair_polartwilight" -> nfMdWeatherPartlyCloudy
+ "partlycloudy_day" -> nfMdWeatherPartlyCloudy
+ "partlycloudy_night" -> nfMdWeatherPartlyCloudy
+ "partlycloudy_polartwilight" -> nfMdWeatherPartlyCloudy
+ -- fog
+ "fog" -> nfMdWeatherFog
+ -- rain
+ "rain" -> nfMdWeatherRainy
+ "lightrain" -> nfMdWeatherRainy
+ "heavyrain" -> nfMdWeatherPouring
+ -- snow
+ "snow" -> nfMdWeatherSnowy
+ "lightsnow" -> nfMdWeatherSnowy
+ "heavysnow" -> nfMdWeatherSnowyHeavy
+ -- sleet
+ "sleet" -> nfMdWeatherHail
+ "lightsleet" -> nfMdWeatherSnowyRainy
+ "heavysleet" -> nfMdWeatherHail
+ -- thunder
+ -- rain + thunder
+ "rainandthunder" -> nfMdWeatherLightning
+ "lightrainandthunder" -> nfMdWeatherLightning
+ "heavyrainandthunder" -> nfMdWeatherLightning
+ -- sleet + thunder
+ "sleetandthunder" -> nfMdWeatherLightning
+ "lightsleetandthunder" -> nfMdWeatherLightning
+ "heavysleetandthunder" -> nfMdWeatherLightning
+ -- snow + thunder
+ "snowandthunder" -> nfMdWeatherLightning
+ "lightsnowandthunder" -> nfMdWeatherLightning
+ "heavysnowandthunder" -> nfMdWeatherLightning
+ -- SHOWERS, map to "partly"
+ -- rain
+ "rainshowers_day" -> nfMdWeatherPartlyRainy
+ "rainshowers_night" -> nfMdWeatherPartlyRainy
+ "rainshowers_polartwilight" -> nfMdWeatherPartlyRainy
+ "lightrainshowers_day" -> nfMdWeatherPartlyRainy
+ "lightrainshowers_night" -> nfMdWeatherPartlyRainy
+ "lightrainshowers_polartwilight" -> nfMdWeatherPartlyRainy
+ "heavyrainshowers_day" -> nfMdWeatherPartlyRainy
+ "heavyrainshowers_night" -> nfMdWeatherPartlyRainy
+ "heavyrainshowers_polartwilight" -> nfMdWeatherPartlyRainy
+ -- snow
+ "snowshowers_day" -> nfMdWeatherPartlySnowy
+ "snowshowers_night" -> nfMdWeatherPartlySnowy
+ "snowshowers_polartwilight" -> nfMdWeatherPartlySnowy
+ "lightsnowshowers_day" -> nfMdWeatherPartlySnowy
+ "lightsnowshowers_night" -> nfMdWeatherPartlySnowy
+ "lightsnowshowers_polartwilight" -> nfMdWeatherPartlySnowy
+ "heavysnowshowers_day" -> nfMdWeatherPartlySnowy
+ "heavysnowshowers_night" -> nfMdWeatherPartlySnowy
+ "heavysnowshowers_polartwilight" -> nfMdWeatherPartlySnowy
+ -- sleet
+ "sleetshowers_day" -> nfMdWeatherPartlySnowyRainy
+ "sleetshowers_night" -> nfMdWeatherPartlySnowyRainy
+ "sleetshowers_polartwilight" -> nfMdWeatherPartlySnowyRainy
+ "heavysleetshowers_day" -> nfMdWeatherPartlySnowyRainy
+ "heavysleetshowers_night" -> nfMdWeatherPartlySnowyRainy
+ "heavysleetshowers_polartwilight" -> nfMdWeatherPartlySnowyRainy
+ "lightsleetshowers_day" -> nfMdWeatherPartlySnowyRainy
+ "lightsleetshowers_night" -> nfMdWeatherPartlySnowyRainy
+ "lightsleetshowers_polartwilight" -> nfMdWeatherPartlySnowyRainy
+ -- thunder
+ -- rain + thunder
+ "rainshowersandthunder_day" -> nfMdWeatherPartlyLightning
+ "rainshowersandthunder_night" -> nfMdWeatherPartlyLightning
+ "rainshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
+ "lightrainshowersandthunder_day" -> nfMdWeatherPartlyLightning
+ "lightrainshowersandthunder_night" -> nfMdWeatherPartlyLightning
+ "lightrainshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
+ "heavyrainshowersandthunder_day" -> nfMdWeatherPartlyLightning
+ "heavyrainshowersandthunder_night" -> nfMdWeatherPartlyLightning
+ "heavyrainshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
+ -- snow + thunder
+ "snowshowersandthunder_day" -> nfMdWeatherPartlyLightning
+ "snowshowersandthunder_night" -> nfMdWeatherPartlyLightning
+ "snowshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
+ "lightssnowshowersandthunder_day" -> nfMdWeatherPartlyLightning
+ "lightssnowshowersandthunder_night" -> nfMdWeatherPartlyLightning
+ "lightssnowshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
+ "heavysnowshowersandthunder_day" -> nfMdWeatherPartlyLightning
+ "heavysnowshowersandthunder_night" -> nfMdWeatherPartlyLightning
+ "heavysnowshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
+ -- sleet + thunder
+ "sleetshowersandthunder_day" -> nfMdWeatherPartlyLightning
+ "sleetshowersandthunder_night" -> nfMdWeatherPartlyLightning
+ "sleetshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
+ "lightssleetshowersandthunder_day" -> nfMdWeatherPartlyLightning
+ "lightssleetshowersandthunder_night" -> nfMdWeatherPartlyLightning
+ "lightssleetshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
+ "heavysleetshowersandthunder_day" -> nfMdWeatherPartlyLightning
+ "heavysleetshowersandthunder_night" -> nfMdWeatherPartlyLightning
+ "heavysleetshowersandthunder_polartwilight" -> nfMdWeatherPartlyLightning
+ _ -> summary.symbol_code
+ )
+ tempMax = P.color P.Red (P.pretty (show details.air_temperature_max))
+ tempMin = P.colorDull P.Green (P.pretty (show details.air_temperature_min))
+
+ nfMdWeatherCloudy = "\xf0590"
+ nfMdWeatherFog = "\xf0591"
+ nfMdWeatherHail = "\xf0592"
+ nfMdWeatherLightning = "\xf0593"
+ nfMdWeatherPartlyCloudy = "\xf0595"
+ nfMdWeatherPartlyLightning = "\xf0f32"
+ nfMdWeatherPartlyRainy = "\xf0f33"
+ nfMdWeatherPartlySnowyRainy = "\xf0f35"
+ nfMdWeatherPartlySnowy = "\xf0f34"
+ nfMdWeatherPouring = "\xf0596"
+ nfMdWeatherRainy = "\xf0597"
+ nfMdWeatherSnowyHeavy = "\xf0f36"
+ nfMdWeatherSnowyRainy = "\xf067f"
+ nfMdWeatherSnowy = "\xf0598"
+ nfMdWeatherSunny = "\xf0599"
+ )
-data LocationData = LocationData
+data Location = Location
{ latitude :: Float,
longitude :: Float
}
deriving (Generic, Show)
-instance FromJSON LocationData
-
-instance (S.MonadSensor m) => S.Aggregate m Location LocationData where
- aggregate _ = forever do
- S.yield . getResponseBody =<< liftIO (httpJSON (fromString "https://reallyfreegeoip.org/json/?fields=lat,lon"))
- threadDelay (5 * 60 * 10 ^ 6)
-
-data CurrentTime = CurrentTime deriving (Show)
-
-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
+instance FromJSON Location
+
+currentLocation :: S.Sensor () Location
+currentLocation =
+ S.sensor
+ (\() -> "location")
+ ( \() yield -> forever do
+ yield . getResponseBody
+ =<< liftIO
+ ( httpJSON $
+ fromString "https://reallyfreegeoip.org/json/?fields=lat,lon"
+ )
+ threadDelay (5 * 60 * 10 ^ 6)
+ )
-currentTimeZone :: (S.MonadSensor m) => S.Sensor m () TimeZone
-currentTimeZone = S.sensor CurrentTimeZone
+currentTime :: S.Sensor () UTCTime
+currentTime =
+ S.sensor
+ (\() -> "currentTime")
+ ( \() yield -> forever do
+ x <- liftIO getCurrentTime
+ yield =<< liftIO getCurrentTime
+ threadDelay
+ (((10 ^ 12) - (fromEnum (utctDayTime x) `mod` (10 ^ 12))) `div` (10 ^ 6))
+ )
-currentTime :: (S.MonadSensor m) => S.Sensor m () UTCTime
-currentTime = S.sensor CurrentTime
+currentTimeZone :: S.Sensor () TimeZone
+currentTimeZone =
+ S.sensor
+ (\() -> "currentTimeZone")
+ ( \() yield -> forever do
+ yield =<< liftIO getCurrentTimeZone <* sleep
+ )
-date :: (S.MonadSensor m) => S.Sensor m () String
+date :: S.Sensor () String
date =
((formatTime defaultTimeLocale "%b %e" .) . utcToLocalTime)
<$> currentTimeZone
<*> currentTime
-time :: (S.MonadSensor m) => S.Sensor m () String
+time :: S.Sensor () String
time =
((formatTime defaultTimeLocale "%R" .) . utcToLocalTime)
<$> currentTimeZone
<*> currentTime
-wmName :: (S.MonadSensor m) => S.Sensor m () String
-wmName = activeWindow >>= maybe (pure "") wmNameOf
+wmName :: S.Sensor () String
+wmName = activeWindow >>> S.withDefaultS "" wmNameOf
data ActiveWindow = ActiveWindow deriving (Show)
-instance (S.MonadSensor m) => S.Aggregate m ActiveWindow (Maybe X.Window) where
- aggregate _ = do
+activeWindow :: S.Sensor () (Maybe X.Window)
+activeWindow = do
+ S.sensor (\() -> "activeWindow") $ \() yield -> do
bracket
( liftIO do
dpy <- X.openDisplay ""
@@ -685,60 +667,63 @@ instance (S.MonadSensor m) => S.Aggregate m ActiveWindow (Maybe X.Window) where
X.nextEvent dpy ev
X.getEvent ev
)
- when (X.ev_atom e /= netActiveWindow) waitForEvent
+ case e of
+ X.PropertyEvent {ev_atom} ->
+ when (ev_atom /= netActiveWindow) waitForEvent
+ _ -> 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
+ Just (0 : _) -> yield Nothing
+ Just (win : _) -> yield (Just (fi win))
+ _ -> 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
+wmNameOf :: S.Sensor X.Window String
+wmNameOf =
+ S.sensor
+ (\win -> printf "wmNameOf %s" (show win))
+ ( \win yield ->
+ 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
+ )
+ case e of
+ X.PropertyEvent {ev_atom} ->
+ when (ev_atom /= netWmName) waitForEvent
+ _ ->
+ waitForEvent
+
+ readWmName = do
+ yield
+ =<< fmap (strip . head) . liftIO . X.wcTextPropertyToTextList dpy
+ =<< liftIO (X.getTextProperty dpy win netWmName)
+ forever do
+ readWmName
+ waitForEvent
+ )
+ )
data WmWorkspaces = WmWorkspaces deriving (Show)
@@ -747,8 +732,9 @@ data Workspace
| Inactive String
deriving (Eq, Typeable, Show)
-instance (S.MonadSensor m) => S.Aggregate m WmWorkspaces [Workspace] where
- aggregate WmWorkspaces = do
+wmWorkspaces :: S.Sensor () [Workspace]
+wmWorkspaces =
+ S.sensor (\() -> "wmWorkspaces") $ \() yield -> do
bracket
( liftIO do
dpy <- X.openDisplay ""
@@ -775,19 +761,21 @@ instance (S.MonadSensor m) => S.Aggregate m WmWorkspaces [Workspace] where
X.nextEvent dpy ev
X.getEvent ev
)
- when
- ( ((not .) . elem)
- (X.ev_atom e)
- [ netClientList,
- netCurrentDesktop,
- netDesktopNames,
- netWmDesktop
- ]
- )
- waitForEvent
+ case e of
+ X.PropertyEvent {ev_atom} ->
+ when
+ ( (((not .) . elem) ev_atom)
+ [ netClientList,
+ netCurrentDesktop,
+ netDesktopNames,
+ netWmDesktop
+ ]
+ )
+ waitForEvent
+ _ -> waitForEvent
readWmWorkspaces = do
- S.yield
+ yield
=<< liftIO do
currentDesktop <-
fmap (fi . head)
@@ -822,9 +810,6 @@ instance (S.MonadSensor m) => S.Aggregate m WmWorkspaces [Workspace] where
waitForEvent
)
-wmWorkspaces :: (S.MonadSensor m) => S.Sensor m () [Workspace]
-wmWorkspaces = S.sensor WmWorkspaces
-
instance P.Pretty [Workspace] where
pretty =
P.Col . intersperse (P.pretty " ") . map P.pretty
diff --git a/app/Ui.hs b/app/Ui.hs
index 34fa101..2261f0a 100644
--- a/app/Ui.hs
+++ b/app/Ui.hs
@@ -23,6 +23,7 @@ module Ui
)
where
+import Control.DeepSeq
import Control.Monad.Reader
import Control.Monad.State (evalStateT, get, modify)
import Data.Default
@@ -35,12 +36,21 @@ import Graphics.X11.Xft qualified as X
import Graphics.X11.Xrender qualified as X
import Pretty qualified as P
-data Ui a = Ui [a] deriving (Eq, Functor, Foldable, Traversable, Show)
+data Ui a = Ui [a]
+ deriving
+ ( Eq,
+ Functor,
+ Foldable,
+ Traversable,
+ Show,
+ Generic,
+ NFData
+ )
data Block a
= Lit a
| Fill
- deriving (Eq, Functor, Show)
+ deriving (Eq, Functor, Show, Generic, NFData)
lit :: (P.Pretty a) => a -> Block P.Doc
lit = Lit . P.pretty
@@ -48,10 +58,8 @@ lit = Lit . P.pretty
fill :: Block a
fill = Fill
-pollUi ::
- Ui (S.Sensor (S.SensorT IO) () (Block P.Doc)) ->
- S.Sensor (S.SensorT IO) () (Ui (Block P.Doc))
-pollUi = sequence
+pollUi :: Ui (S.Sensor () (Block P.Doc)) -> S.Sensor () (Ui (Block P.Doc))
+pollUi (Ui sfs) = Ui <$> S.concatS sfs
layOutUi :: Env -> Ui (Block P.Doc) -> IO Ui'
layOutUi env (Ui bs) = layOut env (Ui' (concatMap go bs))
@@ -146,7 +154,7 @@ renderUi' env@Env {..} colors (Ui' cs') ui@(Ui' cs)
X.xftDrawRect drw bg rect.left 0 rect.width wheight
X.xftDrawString drw fg fnt rect.left h string
-data Ui' = Ui' [C] deriving (Show)
+data Ui' = Ui' [C] deriving (Show, Generic, NFData)
data C = C
{ rect :: Rect,
@@ -154,7 +162,7 @@ data C = C
color :: Maybe (P.Intensity, P.Color),
string :: String
}
- deriving (Show, Eq)
+ deriving (Show, Eq, Generic, NFData)
data Rect = Rect
{ top :: Int,
@@ -162,7 +170,7 @@ data Rect = Rect
width :: Int,
height :: Int
}
- deriving (Generic, Default, Show, Eq)
+ deriving (Generic, Default, Show, Eq, NFData)
io :: (MonadIO m) => IO a -> m a
io = liftIO
diff --git a/astatusbar.cabal b/astatusbar.cabal
index b97b2fb..3e345a4 100644
--- a/astatusbar.cabal
+++ b/astatusbar.cabal
@@ -26,6 +26,7 @@ executable astatusbar
data-default,
deepseq,
directory,
+ dunai,
filepath,
http-conduit,
indexed-traversable,
@@ -41,4 +42,4 @@ executable astatusbar
unliftio,
witherable,
X11,
- X11-xft
+ X11-xft,
diff --git a/default.nix b/default.nix
index a821a15..02d46e1 100644
--- a/default.nix
+++ b/default.nix
@@ -55,9 +55,10 @@ rec {
packages = _: [ astatusbar ];
buildInputs = [
pkgs.cabal-install
- (pkgs.nerdfonts.override { fonts = [ "IosevkaTerm" ]; })
+ pkgs.nerd-fonts.iosevka-term
pkgs.niv
pkgs.ormolu
+ pkgs.pamixer
];
withHoogle = true;
};
diff --git a/nix/sources.json b/nix/sources.json
index acbc22c..243df04 100644
--- a/nix/sources.json
+++ b/nix/sources.json
@@ -1,20 +1,20 @@
{
"nixpkgs": {
- "branch": "release-23.11",
+ "branch": "release-25.05",
"description": "Nix Packages collection",
"homepage": null,
"owner": "NixOS",
"repo": "nixpkgs",
- "rev": "af7e9fb77b8993a7b5f01282c869e503d6cc9e6e",
- "sha256": "174r9nhpmvgrjlr46gvs5vvn38nmlzz0hhr27xz5qaabnlwi6b8m",
+ "rev": "682aaef638791a25f65c5979022bb49bc7fb67b6",
+ "sha256": "0ld0fagf748pck4d8mhskb3ziypi3d8dm2a9vf48586990m1h2y3",
"type": "tarball",
- "url": "https://github.com/NixOS/nixpkgs/archive/af7e9fb77b8993a7b5f01282c869e503d6cc9e6e.tar.gz",
+ "url": "https://github.com/NixOS/nixpkgs/archive/682aaef638791a25f65c5979022bb49bc7fb67b6.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"sensors": {
"branch": "main",
"repo": "git@code.nomath.org:~/sensors",
- "rev": "835b030d4921adccfef83c5a5a076e091f290266",
+ "rev": "19ec714aae58842bddb7d3940c6a864d09ebdec0",
"type": "git"
},
"sh": {