{-# 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 #-}
{-# OPTIONS_GHC -fno-warn-x-partial #-}

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)

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) => m ()
sleep = threadDelay (5 * 10 ^ 5)

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 =
      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 :: 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))

thermal :: S.Sensor () (P.Diagram [Float])
thermal =
  ((\x -> clamp 0 1 (x / 100)) <$$$>) $
    diagram 1 $
      S.sensor (\() -> "thermal") $ \() yield -> forever do
        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 . (/ 1000) . fromIntegral . read @Int . strip)])

clamp :: (Ord a) => a -> a -> a -> a
clamp hi lo
  | hi > lo = min hi . max lo
  | otherwise = clamp lo hi

ioStat :: S.Sensor () Int
ioStat = S.sensor (\() -> "ioStat") $ \() yield -> forever do
  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)

io :: S.Sensor () (P.Diagram [Float])
io = diagram 3 (maxS (rate ioStat))

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

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)

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.Sensor () (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 (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 =
  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.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 isOn (value, batState, _) =
      case batState of
        NotCharging ->
          printBatNotCharging value
        Charging ->
          printBatCharging value
        Discharging ->
          printBatDischarging isOn value

printBatNotCharging :: Float -> P.Doc
printBatNotCharging value =
  mconcat
    [ printBatCapacity value,
      P.pretty "  "
    ]

printBatCharging :: Float -> P.Doc
printBatCharging value =
  mconcat
    [ printBatCapacity value,
      nfOctArrowUp
    ]

printBatDischarging :: Bool -> Float -> P.Doc
printBatDischarging isOn value =
  if value < 0.1
    then
      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 =
  P.pretty $
    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"

nfOctArrowUp :: P.Doc
nfOctArrowUp =
  P.pretty "\xf431 "

nfOctArrowDown :: P.Doc
nfOctArrowDown =
  P.pretty "\xf433 "

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
choice def (x : xs) = x `catch` (\(_ :: SomeException) -> choice def xs)

data Snd = Snd deriving (Show)

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

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.Sensor () (P.Diagram [Float])
disk = diagram 1 diskStat

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 (Show, Generic)

instance FromJSON ForecastData

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

instance FromJSON Next6Hours

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

instance FromJSON Summary

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

instance FromJSON Details

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

instance FromJSON Instant

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

instance FromJSON InstantDetails

instance FromJSON ForecastTimeserie where
  parseJSON value =
    fmap ForecastTimeserie (withObject "ForecastTimeserie" (\v -> v .: fromString "data") value)

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 :: 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.Sensor () P.Doc
weatherForecast = proc () -> do
  loc <- currentLocation -< ()
  forecastData <- weatherForecast' -< loc
  let airTemperature = P.pretty (show forecastData.instant.details.air_temperature)
  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 Location = Location
  { latitude :: Float,
    longitude :: Float
  }
  deriving (Generic, Show)

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

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

currentTimeZone :: S.Sensor () TimeZone
currentTimeZone =
  S.sensor
    (\() -> "currentTimeZone")
    ( \() yield -> forever do
        yield =<< liftIO getCurrentTimeZone <* sleep
    )

date :: S.Sensor () String
date =
  ((formatTime defaultTimeLocale "%b %e" .) . utcToLocalTime)
    <$> currentTimeZone
    <*> currentTime

time :: S.Sensor () String
time =
  ((formatTime defaultTimeLocale "%R" .) . utcToLocalTime)
    <$> currentTimeZone
    <*> currentTime

wmName :: S.Sensor () P.Doc
wmName = activeWindow >>> S.withDefaultS (P.pretty "") wmNameOf

data ActiveWindow = ActiveWindow deriving (Show)

activeWindow :: S.Sensor () (Maybe X.Window)
activeWindow = do
  S.sensor (\() -> "activeWindow") $ \() yield -> 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
                        )
                    case e of
                      X.PropertyEvent {ev_atom} ->
                        when (ev_atom /= netActiveWindow) waitForEvent
                      _ -> waitForEvent

              readActiveWindow = do
                liftIO (X.getWindowProperty32 dpy netActiveWindow root) >>= \case
                  Just (0 : _) -> yield Nothing
                  Just (win : _) -> yield (Just (fi win))
                  _ -> yield Nothing
          forever do
            readActiveWindow
            waitForEvent
      )

wmNameOf :: S.Sensor X.Window P.Doc
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 . P.color P.Magenta . P.pretty
                      =<< fmap (strip . head) . liftIO . X.wcTextPropertyToTextList dpy
                      =<< liftIO (X.getTextProperty dpy win netWmName)
              forever do
                readWmName
                waitForEvent
          )
    )

data WmWorkspaces = WmWorkspaces deriving (Show)

data Workspace
  = Active String
  | Inactive String
  deriving (Eq, Typeable, Show)

wmWorkspaces :: S.Sensor () [Workspace]
wmWorkspaces =
  S.sensor (\() -> "wmWorkspaces") $ \() yield -> 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
                        )
                    case e of
                      X.PropertyEvent {ev_atom} ->
                        when
                          ( (((not .) . elem) ev_atom)
                              [ netClientList,
                                netCurrentDesktop,
                                netDesktopNames,
                                netWmDesktop
                              ]
                          )
                          waitForEvent
                      _ -> waitForEvent

              readWmWorkspaces = do
                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
      )

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.Cyan (P.pretty s)
  pretty (Inactive s) = P.color P.White (P.pretty s)

(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
f <$$> x = fmap f <$> x

(<$$$>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h 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