Hyprland.hs

-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Hyprland
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- Context-integrated helpers for the Hyprland client.
--
-- Hyprland resources are stored directly on 'Context' (not in 'contextState')
-- to avoid deadlocks from nested 'getStateDefault' usage during widget
-- initialization.
-----------------------------------------------------------------------------

module System.Taffybar.Hyprland
  ( -- * Shared Client
    getHyprlandClient
  , getHyprlandClientWith

    -- * Hyprland Monad In TaffyIO
  , HyprlandIO
  , runHyprland

    -- * Shared Event Channel
  , getHyprlandEventChan
  , getHyprlandEventChanWith

    -- * Convenience Runners
  , runHyprlandCommandRawT
  , runHyprlandCommandJsonT
  ) where

import qualified Control.Concurrent.MVar as MV
import           Control.Monad.IO.Class (liftIO)
import           Data.Aeson (FromJSON)
import qualified Data.ByteString as BS

import           Control.Monad.Trans.Reader (ReaderT, asks)

import           System.Taffybar.Context (Context(..), TaffyIO)
import           System.Taffybar.Information.Hyprland
  ( HyprlandClient
  , HyprlandClientConfig
  , HyprlandCommand
  , HyprlandError
  , HyprlandEventChan
  , HyprlandT
  , buildHyprlandEventChan
  , defaultHyprlandClientConfig
  , runHyprlandCommandJson
  , runHyprlandCommandRaw
  , runHyprlandT
  )

-- | Get a shared 'HyprlandClient' from the 'Context' state.
--
-- Note: this uses 'getStateDefault', so the first call wins and subsequent
-- calls return the existing client.
getHyprlandClient :: TaffyIO HyprlandClient
getHyprlandClient = getHyprlandClientWith defaultHyprlandClientConfig

-- | Like 'getHyprlandClient', but allows supplying the initial config.
--
-- The config is only used if the client has not already been created and
-- stored in the 'Context' state.
getHyprlandClientWith :: HyprlandClientConfig -> TaffyIO HyprlandClient
getHyprlandClientWith _cfg = asks hyprlandClient

-- | Hyprland actions in the 'TaffyIO' context.
--
-- Note: 'TaffyIO' is a type synonym, and type synonyms cannot be partially
-- applied. We therefore spell out the underlying 'ReaderT Context IO' here.
type HyprlandIO a = HyprlandT (ReaderT Context IO) a

runHyprland :: HyprlandIO a -> TaffyIO a
runHyprland action = getHyprlandClient >>= \client -> runHyprlandT client action

-- | Get a shared Hyprland event channel from the 'Context' state.
--
-- The channel is backed by a single event socket reader thread, and is safe to
-- use concurrently by multiple widgets via 'subscribeHyprlandEvents'.
getHyprlandEventChan :: TaffyIO HyprlandEventChan
getHyprlandEventChan = getHyprlandEventChanWith defaultHyprlandClientConfig

-- | Like 'getHyprlandEventChan', but allows supplying the initial client config.
--
-- The config is only used if the channel has not already been created and
-- stored in the 'Context' state.
getHyprlandEventChanWith :: HyprlandClientConfig -> TaffyIO HyprlandEventChan
getHyprlandEventChanWith cfg = do
  client <- getHyprlandClientWith cfg
  chanVar <- asks hyprlandEventChanVar
  liftIO $ MV.modifyMVar chanVar $ \existing ->
    case existing of
      Just c -> pure (existing, c)
      Nothing -> do
        c <- buildHyprlandEventChan client
        pure (Just c, c)

runHyprlandCommandRawT :: HyprlandCommand -> TaffyIO (Either HyprlandError BS.ByteString)
runHyprlandCommandRawT cmd =
  getHyprlandClient >>= \client -> liftIO $ runHyprlandCommandRaw client cmd

runHyprlandCommandJsonT :: FromJSON a => HyprlandCommand -> TaffyIO (Either HyprlandError a)
runHyprlandCommandJsonT cmd =
  getHyprlandClient >>= \client -> liftIO $ runHyprlandCommandJson client cmd