HyprlandLayout.hs

{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      : System.Taffybar.Widget.HyprlandLayout
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison <IvanMalison@gmail.com>
-- Stability   : unstable
-- Portability : unportable
--
-- Simple text widget that shows the Hyprland layout used in the currently
-- active workspace.
module System.Taffybar.Widget.HyprlandLayout
  ( HyprlandLayoutConfig (..),
    defaultHyprlandLayoutConfig,
    hyprlandLayoutNew,
  )
where

import Control.Applicative ((<|>))
import Control.Concurrent (killThread)
import Control.Monad (void)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.Aeson (FromJSON (..), withObject, (.:?))
import Data.Default (Default (..))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GI.Gdk
import qualified GI.Gtk as Gtk
import System.Log.Logger (Priority (..))
import System.Taffybar.Context
import System.Taffybar.Hyprland
  ( runHyprlandCommandJsonT,
    runHyprlandCommandRawT,
  )
import qualified System.Taffybar.Information.Hyprland as Hypr
import System.Taffybar.Information.Wakeup (taffyForeverWithDelay)
import System.Taffybar.Util
import System.Taffybar.Widget.Util

-- | Configuration for 'hyprlandLayoutNew'.
data HyprlandLayoutConfig = HyprlandLayoutConfig
  { formatLayout :: T.Text -> TaffyIO T.Text,
    updateIntervalSeconds :: Double,
    onLeftClick :: Maybe [String],
    onRightClick :: Maybe [String]
  }

instance Default HyprlandLayoutConfig where
  def = defaultHyprlandLayoutConfig

-- | Default Hyprland layout widget configuration.
defaultHyprlandLayoutConfig :: HyprlandLayoutConfig
defaultHyprlandLayoutConfig =
  HyprlandLayoutConfig
    { formatLayout = return,
      updateIntervalSeconds = 1,
      onLeftClick = Nothing,
      onRightClick = Nothing
    }

-- | Create a new Hyprland Layout widget.
hyprlandLayoutNew :: HyprlandLayoutConfig -> TaffyIO Gtk.Widget
hyprlandLayoutNew config = do
  ctx <- ask
  label <- lift $ Gtk.labelNew (Nothing :: Maybe T.Text)
  _ <- widgetSetClassGI label "layout-label"

  let refresh = do
        layoutText <- getHyprlandLayoutText
        markup <- formatLayout config layoutText
        lift $ postGUIASync $ Gtk.labelSetMarkup label markup

  void refresh
  threadId <- taffyForeverWithDelay (updateIntervalSeconds config) (void refresh)

  ebox <- lift Gtk.eventBoxNew
  lift $ Gtk.containerAdd ebox label
  _ <- lift $ Gtk.onWidgetButtonPressEvent ebox $ dispatchButtonEvent ctx config
  _ <- lift $ Gtk.onWidgetUnrealize ebox $ killThread threadId
  lift $ Gtk.widgetShowAll ebox
  Gtk.toWidget ebox

-- | Call the configured dispatch action depending on click.
dispatchButtonEvent :: Context -> HyprlandLayoutConfig -> EventButton -> IO Bool
dispatchButtonEvent context config btn = do
  pressType <- getEventButtonType btn
  buttonNumber <- getEventButtonButton btn
  case pressType of
    EventTypeButtonPress ->
      case buttonNumber of
        1 -> runReaderT (dispatchMaybe $ onLeftClick config) context >> return True
        3 -> runReaderT (dispatchMaybe $ onRightClick config) context >> return True
        _ -> return False
    _ -> return False

-- | Dispatch a Hyprland command if provided.
dispatchMaybe :: Maybe [String] -> TaffyIO ()
dispatchMaybe maybeArgs =
  case maybeArgs of
    Nothing -> return ()
    Just args -> do
      result <- runHyprlandCommandRawT (Hypr.hyprCommand ("dispatch" : args))
      case result of
        Left err ->
          logPrintF
            "System.Taffybar.Widget.HyprlandLayout"
            WARNING
            "Failed to dispatch Hyprland command: %s"
            (show err)
        Right _ -> return ()

-- Hyprland JSON helpers

newtype HyprlandActiveWorkspace = HyprlandActiveWorkspace
  { hawLayout :: Maybe Text
  }
  deriving (Show, Eq)

instance FromJSON HyprlandActiveWorkspace where
  parseJSON = withObject "HyprlandActiveWorkspace" $ \v -> do
    layout <- v .:? "layout" <|> v .:? "layoutName" <|> v .:? "layoutname"
    return $ HyprlandActiveWorkspace layout

getHyprlandLayoutText :: TaffyIO T.Text
getHyprlandLayoutText = do
  result <- runHyprctlJson ["-j", "activeworkspace"]
  case result of
    Left err ->
      logPrintF
        "System.Taffybar.Widget.HyprlandLayout"
        WARNING
        "hyprctl activeworkspace failed: %s"
        err
        >> return ""
    Right (HyprlandActiveWorkspace layout) ->
      return $ fromMaybe "" layout

runHyprctlJson :: (FromJSON a) => [String] -> TaffyIO (Either String a)
runHyprctlJson args = do
  let args' =
        case args of
          ("-j" : rest) -> rest
          _ -> args
  result <- runHyprlandCommandJsonT (Hypr.hyprCommandJson args')
  pure $ case result of
    Left err -> Left (show err)
    Right out -> Right out