diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Main.hs | 12 | ||||
| -rw-r--r-- | app/Pretty/Color.hs | 8 | ||||
| -rw-r--r-- | app/Sensor.hs | 837 | ||||
| -rw-r--r-- | app/Ui.hs | 26 |
4 files changed, 440 insertions, 443 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 @@ -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 |