path: root/app/Main.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Main where

import Control.Arrow
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Bits
import Data.List
import Data.Map qualified as M
import Data.Maybe
import Data.Sensor qualified as S
import GHC.Ptr (Ptr)
import Graphics.X11 qualified as X
import Graphics.X11.Xft qualified as X
import Graphics.X11.Xlib.Extras qualified as X
import Options.Applicative qualified as O
import Pretty qualified as P
import Sensor
import Ui hiding (Env)
import Ui qualified
import UnliftIO.STM

data Args = Args
  { icons :: Bool,
    spacing :: Int
  }

args :: O.ParserInfo Args
args = O.info (Args <$> iconsArg <*> spacingArg) O.idm

iconsArg :: O.Parser Bool
iconsArg = O.switch (O.long "icons")

spacingArg :: O.Parser Int
spacingArg = O.option O.auto (O.long "spacing" <> O.value 0)

data Env = Env
  { dpy :: X.Display,
    win :: X.Window,
    wleft :: Int,
    wheight :: Int,
    gc :: X.GC,
    pixm :: X.Pixmap,
    fnt :: X.XftFont,
    drw :: X.XftDraw,
    cmap :: X.Colormap,
    vis :: X.Visual,
    xcolors :: M.Map P.XColor String,
    qT :: TQueue ()
  }

type Colors = M.Map (P.Intensity, P.Color) X.XftColor

data State = State
  { dirty :: Bool,
    ui :: Maybe (Ui (Block P.Doc)),
    ui' :: Maybe Ui',
    wwidth :: Int,
    swidth :: Int,
    sheight :: Int
  }

main :: IO ()
main = do
  O.execParser args >>= \args -> do
    bracket (createWindow args) destroyWindow $ \(env, stateT) ->
      withColors env (run env stateT)

run :: Env -> TVar State -> Colors -> IO ()
run env stateT colors = forever do
  atomically do
    state <- readTVar stateT
    checkSTM (isJust state.ui)
    readTQueue env.qT
  state <- resizeIfNeeded env stateT
  ui'' <- paint env state colors
  atomically do
    state <- readTVar stateT
    writeTVar stateT state {ui' = Just ui''}

resizeIfNeeded :: Env -> TVar State -> IO State
resizeIfNeeded Env {..} stateT = do
  (needsResize, state) <- atomically do
    state <- readTVar stateT
    let state' :: State
        state' = state {wwidth = state.swidth}
    writeTVar stateT state'
    pure (state.wwidth /= state.sheight, state')
  when (needsResize) do
    X.resizeWindow dpy win (fi state.wwidth) (fi wheight)
    X.sync dpy False
  pure state

paint :: Env -> State -> Colors -> IO Ui'
paint Env {..} State {ui = fromJust -> ui, ..} colors = do
  let env' = Ui.Env {..}
  ui'' <- layOutUi env' ui
  maybe
    (renderUi env' colors ui'')
    (\ui' -> renderUi' env' colors ui' ui'')
    ui'
  X.copyArea dpy pixm win gc 0 0 (fi wwidth) (fi wheight) 0 0
  X.sync dpy False
  pure ui''

processEvents :: Ptr X.XEvent -> Env -> TVar State -> IO ()
processEvents ev env@(Env {..}) stateT = do
  timeOut <- X.waitForEvent dpy 1_000_000_000
  unless timeOut do
    processEvent ev env stateT
    processEvents ev env stateT

processEvent :: Ptr X.XEvent -> Env -> TVar State -> IO ()
processEvent ev (Env {..}) stateT = do
  X.nextEvent dpy ev
  e <- X.getEvent ev
  if
    | X.ExposeEvent {} <- e -> atomically do
        state <- readTVar stateT
        writeTVar stateT state {dirty = True}
        writeTQueue qT ()
    | X.ConfigureEvent {ev_width, ev_height} <- e -> atomically do
        state <- readTVar stateT
        (writeTVar stateT)
          state
            { swidth = fi ev_width,
              sheight = fi ev_height
            }
        writeTQueue qT ()
    | otherwise -> pure ()

destroyWindow :: (Env, TVar State) -> IO ()
destroyWindow (Env {..}, _) = do
  X.destroyWindow dpy win

createWindow :: Args -> IO (Env, TVar State)
createWindow args = do
  dpy <- X.openDisplay ""
  let scrn = X.defaultScreen dpy
      scr = X.defaultScreenOfDisplay dpy
      root = X.defaultRootWindow dpy
      trueColor = 4
  X.selectInput dpy root X.structureNotifyMask
  Just vinfo <- X.matchVisualInfo dpy scrn 32 trueColor
  let cls = X.inputOutput
      dpth = X.visualInfo_depth vinfo
      vis = X.visualInfo_visual vinfo
      vmsk = X.cWColormap .|. X.cWBorderPixel .|. X.cWBackingPixel .|. X.cWOverrideRedirect
      swidth = fi (X.displayWidth dpy scrn)
      sheight = fi (X.displayHeight dpy scrn)
      wwidth = swidth - 2 * wspac
      wspac = args.spacing
      wleft = wspac
  fnt <- X.xftFontOpen dpy scr "IosevkaTerm Nerd Font:size=14"
  ascent <- X.xftfont_ascent fnt
  descent <- X.xftfont_descent fnt
  let wheight = ascent + descent
  cmap <- X.createColormap dpy root vis X.allocNone
  win <- X.allocaSetWindowAttributes $ \attr -> do
    X.set_colormap attr cmap
    X.set_border_pixel attr 0
    X.set_background_pixel attr 0
    X.set_override_redirect attr True
    X.createWindow dpy root (fi wleft) 0 (fi wwidth) (fi wheight) 0 dpth cls vis vmsk attr
  atom <- X.internAtom dpy "ATOM" True
  wmState <- X.internAtom dpy "_NET_WM_STATE" False
  wmStateSticky <- X.internAtom dpy "_NET_WM_STATE_STICKY" False
  wmStateAbove <- X.internAtom dpy "_NET_WM_STATE_ABOVE" False
  wmWindowType <- X.internAtom dpy "_NET_WM_WINDOW_TYPE" False
  wmWindowTypeDock <- X.internAtom dpy "_NET_WM_WINDOW_TYPE_DOCK" False
  wmStrut <- X.internAtom dpy "_NET_WM_STRUT" False
  wmStrutPartial <- X.internAtom dpy "_NET_WM_STRUT_PARTIAL" False
  X.changeProperty32 dpy win wmState atom X.propModeReplace $
    [ fi wmStateAbove,
      fi wmStateSticky
    ]
  X.changeProperty32 dpy win wmWindowType atom X.propModeReplace $
    [ fi wmWindowTypeDock
    ]
  X.changeProperty32 dpy win wmStrut atom X.propModeReplace $
    [0, 0, fi (wheight + wspac), 0]
  X.changeProperty32 dpy win wmStrutPartial atom X.propModeReplace $
    [0, 0, fi (wheight + wspac), 0, 0, 0, 0, 0, fi wleft, fi wwidth, 0, 0]
  pixm <- X.createPixmap dpy win (fi wwidth) (fi wheight) dpth
  gc <- X.createGC dpy win
  drw <- X.xftDrawCreate dpy pixm vis cmap
  X.mapWindow dpy win
  let dirty = True
  let ui =
        Ui $
          intercalate [pure (lit " ")] $
            [ [lit <$> wmWorkspaces],
              [litShrink <$> wmName, pure fill],
              [pure (lit (if args.icons then "\xf4bc " else "cpu")), lit <$> cpu],
              [pure (lit (if args.icons then "\xf035b " else "mem")), lit <$> mem],
              [pure (lit (if args.icons then "\xf0a0 " else "disk")), lit <$> disk],
              [pure (lit (if args.icons then "\xf1638 " else "io")), lit <$> io],
              [pure (lit (if args.icons then "\xf0200 " else "net")), lit <$> net],
              [pure (lit (if args.icons then "\xf2cb" else "temp")), lit <$> thermal],
              [lit <$> bat],
              [lit <$> Sensor.snd],
              -- [lit <$> weatherForecast],
              [pure (lit " "), lit <$> date, pure (lit ", "), lit <$> time]
            ]
  xcolors <- do
    X.rmInitialize
    rdb <- X.rmGetStringDatabase (X.resourceManagerString dpy)
    M.fromList
      <$> mapM
        ( \(n, def) -> do
            (toEnum n,) . fromMaybe def
              <$> X.rmGetResource rdb ("astatusbar*color" ++ show n)
        )
        [ (0 {- black -}, "rgb:0/0/0"),
          (1 {- red3 -}, "rgb:205/0/0"),
          (2 {- green3 -}, "rgb:0/205/0"),
          (3 {- yellow3 -}, "rgb:205/205/0"),
          (4 {- blue2 -}, "rgb:0/0/238"),
          (5 {- meganta3 -}, "rgb:205/0/205"),
          (6 {- cyan3 -}, "rgb:0/205/205"),
          (7 {- gray90 -}, "rgb:229/229/229"),
          (8 {- gray50 -}, "rgb:127/127/127"),
          (9 {- red -}, "rgb:255/0/0"),
          (10 {- green -}, "rgb:0/255/0"),
          (11 {- yellow -}, "rgb:255/255/0"),
          (12, "rgb:5c/5c/ff"),
          (13 {- meganta -}, "rgb:255/0/255"),
          (14 {- cyan -}, "rgb:0/255/255"),
          (15 {- white -}, "rgb:255/255/255")
        ]
  qT <- atomically do
    qT <- newTQueue
    writeTQueue qT ()
    pure qT
  let env = Env {..}
  stateT <-
    newTVarIO
      State
        { ui = Nothing,
          ui' = Nothing,
          ..
        }
  void $ forkIO $ X.allocaXEvent $ \ev -> forever do
    processEvents ev env stateT
  void $ forkIO do
    S.reactimateS
      ( pollUi ui
          >>> S.arrS
            ( \ui -> atomically do
                state <- readTVar stateT
                writeTVar stateT state {ui = Just ui}
                writeTQueue qT ()
            )
      )
  pure (env, stateT)

withColors :: Env -> (Colors -> IO a) -> IO a
withColors Env {..} act = do
  X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Vivid, P.Black)) $ \black -> do
    X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Vivid, P.Red)) $ \red -> do
      X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Vivid, P.Green)) $ \green -> do
        X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Vivid, P.Yellow)) $ \yellow -> do
          X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Vivid, P.Blue)) $ \blue -> do
            X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Vivid, P.Magenta)) $ \magenta -> do
              X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Vivid, P.Cyan)) $ \cyan -> do
                X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Vivid, P.White)) $ \white -> do
                  X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Dull, P.Black)) $ \dullBlack -> do
                    X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Dull, P.Red)) $ \dullRred -> do
                      X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Dull, P.Green)) $ \dullGreen -> do
                        X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Dull, P.Yellow)) $ \dullYellow -> do
                          X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Dull, P.Blue)) $ \dullBlue -> do
                            X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Dull, P.Magenta)) $ \dullMagenta -> do
                              X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Dull, P.Cyan)) $ \dullCyan -> do
                                X.withXftColorName dpy vis cmap (xcolors M.! P.toXColor (P.Dull, P.White)) $ \dullWhite -> do
                                  let colors =
                                        M.fromList
                                          [ ((P.Vivid, P.Black), black),
                                            ((P.Vivid, P.Red), red),
                                            ((P.Vivid, P.Green), green),
                                            ((P.Vivid, P.Yellow), yellow),
                                            ((P.Vivid, P.Blue), blue),
                                            ((P.Vivid, P.Magenta), magenta),
                                            ((P.Vivid, P.Cyan), cyan),
                                            ((P.Vivid, P.White), white),
                                            ((P.Dull, P.Black), dullBlack),
                                            ((P.Dull, P.Red), dullRred),
                                            ((P.Dull, P.Green), dullGreen),
                                            ((P.Dull, P.Yellow), dullYellow),
                                            ((P.Dull, P.Blue), dullBlue),
                                            ((P.Dull, P.Magenta), dullMagenta),
                                            ((P.Dull, P.Cyan), dullCyan),
                                            ((P.Dull, P.White), dullWhite)
                                          ]

                                  act colors

fi :: (Integral a, Num b) => a -> b
fi = fromIntegral

clamp :: (Ord a) => a -> a -> a -> a
clamp mi ma = max mi . min ma