path: root/app/Sensor.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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
  ( cpu,
    io,
    net,
    mem,
    bat,
    Sensor.snd,
    disk,
    date,
    thermal,
    time,
    wmName,
    weatherForecast,
    wmWorkspaces,
  )
where

import Control.Arrow
import Control.DeepSeq
import Control.Monad
import Control.Monad.Reader
import Data.Aeson
import Data.Char
import Data.Dynamic
import Data.Functor.WithIndex
import Data.List
import Data.Maybe
import Data.Sensor qualified as S
import Data.Set qualified as S
import Data.String
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 Network.HTTP.Simple
import Pretty qualified as P
import Process.Shell (sh)
import Safe
import System.Directory
import System.FilePath
import System.IO (hGetContents)
import System.Posix.StatVFS
import System.Posix.Types (Fd (..))
import Text.Printf
import UnliftIO
import UnliftIO.Concurrent
import Witherable (ifilter)
import Prelude hiding (readFile)

data CpuStatData = CpuStatData
  { used :: Int,
    total :: Int
  }
  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
    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
        )
        (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 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))
  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])
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 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])
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)

data BatState
  = NotCharging
  | Charging
  | Discharging
  deriving (Generic, Eq, NFData, Show)

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)])

parseBatState :: String -> BatState
parseBatState string =
  case strip string of
    "not charging" -> NotCharging
    "charging" -> Charging
    "discharging" -> Discharging
    _ -> error ("invalid bat state: " ++ string)

parseBatType :: String -> BatType
parseBatType string =
  case strip string of
    "mains" -> Mains
    "battery" -> Bat
    "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
  where
    isBat (_, _, batType) =
      batType == Bat
    printBat :: (S.MonadSensor m) => (Float, BatState, BatType) -> S.Sensor m () P.Doc
    printBat (value, batState, _) =
      case batState of
        NotCharging ->
          pure (printBatNotCharging value)
        Charging ->
          pure (printBatCharging value)
        Discharging ->
          printBatDischarging value

printBatNotCharging :: Float -> P.Doc
printBatNotCharging value =
  if
    | value >= 0.95 -> P.pretty "\xf0079"
    | value >= 0.9 -> P.pretty "\xf0082"
    | value >= 0.8 -> P.pretty "\xf0081"
    | value >= 0.7 -> P.pretty "\xf0080"
    | value >= 0.6 -> P.pretty "\xf007f"
    | value >= 0.5 -> P.pretty "\xf007e"
    | value >= 0.4 -> P.pretty "\xf007d"
    | value >= 0.3 -> P.pretty "\xf007c"
    | value >= 0.2 -> P.pretty "\xf007b"
    | value >= 0.1 -> P.pretty "\xf007a"
    | otherwise -> P.pretty "\xf008e"

printBatCharging :: Float -> P.Doc
printBatCharging value =
  if
    | value >= 0.9 -> P.pretty "\xf0085"
    | value >= 0.8 -> P.pretty "\xf008b"
    | value >= 0.7 -> P.pretty "\xf008a"
    | value >= 0.6 -> P.pretty "\xf089e"
    | value >= 0.5 -> P.pretty "\xf0089"
    | value >= 0.4 -> P.pretty "\xf089d"
    | value >= 0.3 -> P.pretty "\xf0088"
    | value >= 0.2 -> P.pretty "\xf0087"
    | value >= 0.1 -> P.pretty "\xf0086"
    | otherwise -> P.pretty "\xf089c"

printBatDischarging :: (S.MonadSensor m) => Float -> S.Sensor m () P.Doc
printBatDischarging value =
  if value < 0.1
    then
      ( \b ->
          if b
            then mconcat [P.pretty batValue, P.pretty "\xf433"]
            else (P.color P.Red) (mconcat [P.pretty "\xf0083", P.pretty "\xf433"])
      )
        <$> blink
    else pure (mconcat [P.pretty batValue, P.pretty "\xf433"])
  where
    batValue =
      if
        | value >= 0.95 -> "\xf0079"
        | value >= 0.9 -> "\xf0082"
        | value >= 0.8 -> "\xf0081"
        | value >= 0.7 -> "\xf0080"
        | value >= 0.6 -> "\xf007f"
        | value >= 0.5 -> "\xf007e"
        | value >= 0.4 -> "\xf007d"
        | value >= 0.3 -> "\xf007c"
        | value >= 0.2 -> "\xf007b"
        | value >= 0.1 -> "\xf007a"
        | otherwise -> "\xf008e"

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)

choice :: a -> [IO a] -> IO a
choice def [] = pure def
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"
    )

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

disk :: (S.MonadSensor m) => S.Sensor m () (P.Diagram [Float])
disk = diagram 1 diskStat

data WeatherForecast = WeatherForecast LocationData deriving (Show)

data Forecast = Forecast
  { properties :: ForecastProperties
  }
  deriving (Generic)

instance FromJSON Forecast

data ForecastProperties = ForecastProperties
  { timeseries :: [ForecastTimeserie]
  }
  deriving (Generic)

instance FromJSON ForecastProperties

data ForecastTimeserie = ForecastTimeserie
  { data_ :: ForecastData
  }
  deriving (Generic)

data ForecastData = ForecastData
  { next_6_hours :: Maybe Next6Hours,
    instant :: Instant
  }
  deriving (Generic)

instance FromJSON ForecastData

data Next6Hours = Next6Hours
  { summary :: Summary,
    details :: Details
  }
  deriving (Generic)

instance FromJSON Next6Hours

data Summary = Summary
  { symbol_code :: String
  }
  deriving (Generic)

instance FromJSON Summary

data Details = Details
  { air_temperature_max :: Float,
    air_temperature_min :: Float,
    precipitation_amount :: Float
  }
  deriving (Generic)

instance FromJSON Details

data Instant = Instant
  { details :: InstantDetails
  }
  deriving (Generic)

instance FromJSON Instant

data InstantDetails = InstantDetails
  { air_temperature :: Float
  }
  deriving (Generic)

instance FromJSON InstantDetails

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)

getForecast :: LocationData -> IO Forecast
getForecast LocationData {..} = 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
  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

data LocationData = LocationData
  { 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

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 (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 [Workspace] where
  pretty =
    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.color P.Cyan (P.pretty s)

(<$$>) :: (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