eww.yuck

(deflisten workspaces `./scripts/manager`)

(defwidget workspacewidget []
  (box
   :class "workspaces"
   :orientation "vertical"
       :space-evenly false
       :valign "start"

       (for ws in workspaces
         (button
          :class {ws.focused ? "focused" : "unfocused"}
          :onclick "swaymsg 'workspace ${ws.name}'"
                 "${ws.name}"))))

;(defwidget metric [label value onchange]
;           (box)

(defpoll clock_h :interval "5m" "date +\%I")
(defpoll clock_m :interval "5s" "date +\%M")
(defpoll clock_day :interval "5s" "date +\%d")
(defpoll clock_month :interval "5s" "date +\%m")
(defwidget clock []
           (box
            :class "clock"
            :orientation "v"
            (label :text "${clock_h}")
            (label :text "${clock_m}")
            (label :text "${clock_day}")
            (label :text "${clock_month}")))

;; maybe I should just check for the existence of the bat?
(defwidget battery [?show]
    (box
      :visible {show != ""}
      :class {show != "" ? EWW_BATTERY[show].capacity <= 15 ? "battery-critical" : "battery" : "battery" }
      :orientation "v"
      (image
       :visible {show != ""}
       :image-width 24
        :path "${EWW_CONFIG_DIR}/images/battery.svg")
        "${show != "" ? EWW_BATTERY[show].capacity : 0}"))

(defwidget mem []
    (box
      :class {EWW_RAM.used_mem_perc >= 90 ? "mem-critical" : "mem" }
      :orientation "v"
      (image
       :image-width 24
        :fill-svg "white"
        :path "${EWW_CONFIG_DIR}/images/memory.svg")
        "${round(EWW_RAM.used_mem_perc,0)}"))

(defwidget cpu []
      (box
      :class {EWW_CPU.avg >= 90 ? "cpu-critical" : "cpu" }
      :orientation "v"
      (image
       :fill-svg "white"
       :image-width 24
        :path "${EWW_CONFIG_DIR}/images/cpu.svg")
        "${round(EWW_CPU.avg,0)}"))

(defwidget left []
           (box
            :orientation "vertical"
            :valign "start"
           (workspacewidget)))

(defwidget center []
           (box
            :orientation "vertical"
            :valign "center"
            ))


(defwidget right [?showbattery]
           (box
            :orientation "vertical"
            :valign "end"
            :space-evenly false
            (systray
             :class "systray"
             :orientation "vertical")
            (battery :show showbattery)
            (cpu)
            (mem)
            (clock)
            ))

(defwidget top-level [?showbattery]
          (centerbox
           :class "bar-container"
           :orientation "vertical"
           (left)
           (center)
           (right :showbattery showbattery)))

(defwindow bar [?showbattery]
           :monitor '["eDP-1","DP-1", 0]'
           :geometry (geometry :x "0"
                               :y "0"
                               :width "24px"
                               :height "100%"
                               :anchor "left center")
           :stacking "fg"
           :exclusive true
           :focusable "none"
  (top-level :showbattery showbattery))

manager.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad
import Data.IORef

import Data.Maybe (fromMaybe, fromJust)
import Data.Either (fromRight)

import System.IO
import System.Process.Typed as TP

import qualified Data.Aeson as Aeson
import Data.Aeson as Aeson ((.=))
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS

import Control.Lens hiding ((.=))
import Data.Aeson.Lens

import GHC.IO.Handle.FD (openFileBlocking)

import System.IO.Unsafe (unsafePerformIO)
import System.Environment
import qualified Debug.Trace as Trace (trace)

import Data.List
import Data.Char (isDigit)

import qualified Data.Text as T
import qualified Data.Text.Read as T

import GHC.Generics

shouldDebug :: Bool
shouldDebug = unsafePerformIO $ fmap (any (=="--debug")) getArgs

redString a = "\ESC[0;31m" ++ a ++ "\ESC[0m"
yellowString a = "\ESC[0;33m" ++ a ++ "\ESC[0m"

logTrace = Trace.trace . yellowString

debugTrace = if shouldDebug then Trace.trace . redString else const id

debugTraceId :: Show a => String -> a -> a
debugTraceId msg a = debugTrace (msg ++ ": " ++ show a) a

subscriptions :: [ String ]
subscriptions = [ "workspace" ]

data Workspace = Workspace
  { name :: T.Text
  , focused :: Bool
  } deriving (Show, Eq, Generic, Aeson.ToJSON)

-- TODO probalby a way to do this automatically
makeLensesFor [("name", "_name"), ("focused", "_focused")] ''Workspace

naturalCmp :: T.Text -> T.Text -> Ordering
naturalCmp "" "" = EQ
naturalCmp "" b  = GT
naturalCmp a ""  = LT
naturalCmp a b
  |      isDigit  (a `T.index` 0) && not (isDigit (b `T.index` 0)) = GT
  | not (isDigit $ a `T.index` 0) &&      isDigit (b `T.index` 0)  = LT
  | not (isDigit $ a `T.index` 0) && not (isDigit $ b `T.index` 0) = compare a b
  | otherwise = compare a' b'
    where
      a' :: Int
      a' = fst . fromRight undefined $ T.decimal a
      b' :: Int
      b' = fst . fromRight undefined $ T.decimal b

sortWorkspaces = sortBy (\a b -> naturalCmp (name a) (name b))

updateWorkspaces :: Aeson.Value -> [ Workspace ] -> [ Workspace ]
updateWorkspaces json =  focus . defocus
  where
    name' = fromMaybe "" $ json ^? key "name" . _String
    defocus = (traverse . filtered (view _focused) . _focused) .~ False
    focus = (traverse . filtered ((==name') . view _name) . _focused) .~ True

addWorkspace json = insertBy (\a b -> naturalCmp (name a) (name b)) ws
  where
    name' = fromMaybe "" $ json ^? key "name" . _String
    ws = Workspace name' True

removeWorkspace json = filter ((/=name') . view _name)
  where
    name' = fromMaybe "" $ json ^? key "name" . _String

toWorkspaces :: Maybe [Aeson.Value] -> [Workspace]
toWorkspaces Nothing = []
toWorkspaces (Just objs) = toWorkspaces' objs
  where
    toWorkspaces' [] = []
    toWorkspaces' (obj:ws) = fromJust (toWorkspace obj) : toWorkspaces' ws
    toWorkspace obj = Workspace
      <$> (obj ^? key "name" . _String)
      <*> (obj ^? key "focused" . _Bool)

swaymsgProc =
    setStdout createPipe
  $ setStderr createPipe
  $ proc "swaymsg" [ "-m"
                   , "-t", "subscribe"
                   , LBS.unpack (Aeson.encode subscriptions)  ]

openFifoForWrite fp = do
  openFileBlocking fp WriteMode

workspaceWriteLoop needsWrite outIORef = do
  forever go
  where
    go = do
      () <- takeMVar needsWrite
      v <- readIORef outIORef
      LBS.putStrLn (Aeson.encode v)
      hFlush stdout

needsWriteExternLoop needsWrite = do
  f <- openFile "./scripts/workspace.fifo" ReadMode
  forever $ do
    eof <- hIsEOF f
    unless eof $ hGetLine f >> putMVar needsWrite ()
  hClose f

initWorkspaces = do
  logTrace "init workspace" $ return ()
  (stdout, _) <- readProcess_ "swaymsg -t get_workspaces"
  return . sortWorkspaces . toWorkspaces $ Aeson.decode stdout

swayWorkstationEventLoop rawMsg =
 withProcessWait_ swaymsgProc $
       \(process) -> do
         let
           hOut = TP.getStdout process
           hErr = TP.getStderr process

         hSetBuffering hOut LineBuffering
         forkIO . forever $ putMVar rawMsg =<< BS.hGetLine hOut
         _ <- waitExitCode process
         return ()

main :: IO ()
main = do
  rawMsg <- newEmptyMVar
  needsWrite <- newEmptyMVar

  outIORef <- newIORef =<< initWorkspaces

  forkIO $ needsWriteExternLoop needsWrite

  forkIO $ workspaceWriteLoop needsWrite outIORef

  forkIO $ swayWorkstationEventLoop rawMsg

  forever $ do
    msg <- takeMVar rawMsg
    let
      change = fromJust $ msg ^? key "change"
      current = fromJust $ msg ^? key "current"
    -- when shouldDebug $ print current
    atomicModifyIORef' outIORef $  (,()) . debugTraceId "updating" . case change of
      "focus" -> updateWorkspaces current
      "init"  -> addWorkspace current
      "empty" -> removeWorkspace current
      "reload" -> id -- const ws
      _       -> id
    putMVar needsWrite ()