{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.DBus.Toggle
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This module provides a dbus interface that allows users to toggle the display
-- of taffybar on each monitor while it is running.
-----------------------------------------------------------------------------

module System.Taffybar.DBus.Toggle ( handleDBusToggles ) where

import qualified Control.Concurrent.MVar as MV
import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.Reader
import           DBus
import           DBus.Client
import           Data.Int
import qualified Data.Map as M
import           Data.Maybe
import qualified GI.Gdk as Gdk
import           Graphics.UI.GIGtkStrut
import           System.Directory
import           System.FilePath.Posix
import           System.Log.Logger
import           System.Taffybar.Context
import           System.Taffybar.Util
import           Text.Printf
import           Text.Read ( readMaybe )

-- $usage
--
-- To use this module, import it in your taffybar.hs and wrap your config with
-- the 'handleDBusToggles' function:
--
-- > main = dyreTaffybar $ handleDBusToggles myConfig
--
-- To toggle taffybar on the monitor that is currently active, issue the
-- following command:
--
-- > dbus-send --print-reply=literal --dest=taffybar.toggle /taffybar/toggle taffybar.toggle.toggleCurrent

logIO :: System.Log.Logger.Priority -> String -> IO ()
logIO :: Priority -> FilePath -> IO ()
logIO = FilePath -> Priority -> FilePath -> IO ()
logM FilePath
"System.Taffybar.DBus.Toggle"

logT :: MonadIO m => System.Log.Logger.Priority -> String -> m ()
logT :: forall (m :: * -> *). MonadIO m => Priority -> FilePath -> m ()
logT Priority
p = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (FilePath -> IO ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Priority -> FilePath -> IO ()
logIO Priority
p

getActiveMonitorNumber :: MaybeT IO Int
getActiveMonitorNumber :: MaybeT IO Int
getActiveMonitorNumber = do
  display <- IO (Maybe Display) -> MaybeT IO Display
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT IO (Maybe Display)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m (Maybe Display)
Gdk.displayGetDefault
  seat <- lift $ Gdk.displayGetDefaultSeat display
  device <- MaybeT $ Gdk.seatGetPointer seat
  lift $ do
    (_, x, y) <- Gdk.deviceGetPosition device
    Gdk.displayGetMonitorAtPoint display x y >>= getMonitorNumber

getMonitorNumber :: Gdk.Monitor -> IO Int
getMonitorNumber :: Monitor -> IO Int
getMonitorNumber Monitor
monitor = do
  display <- Monitor -> IO Display
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMonitor a) =>
a -> m Display
Gdk.monitorGetDisplay Monitor
monitor
  monitorCount <- Gdk.displayGetNMonitors display
  monitors <- mapM (Gdk.displayGetMonitor display) [0..(monitorCount-1)]
  monitorGeometry <- Gdk.getMonitorGeometry monitor
  let equalsMonitor (Just Monitor
other, Int
_) =
        do
          otherGeometry <- Monitor -> IO (Maybe Rectangle)
forall (m :: * -> *) o.
(MonadIO m, IsMonitor o) =>
o -> m (Maybe Rectangle)
Gdk.getMonitorGeometry Monitor
other
          case (otherGeometry, monitorGeometry) of
               (Maybe Rectangle
Nothing, Maybe Rectangle
Nothing) -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
               (Just Rectangle
g1, Just Rectangle
g2) -> Rectangle -> Rectangle -> IO Bool
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Rectangle -> Rectangle -> m Bool
Gdk.rectangleEqual Rectangle
g1 Rectangle
g2
               (Maybe Rectangle, Maybe Rectangle)
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      equalsMonitor (Maybe Monitor, Int)
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  snd . fromMaybe (Nothing, 0) . listToMaybe <$>
      filterM equalsMonitor (zip monitors [0..])

taffybarTogglePath :: ObjectPath
taffybarTogglePath :: ObjectPath
taffybarTogglePath = ObjectPath
"/taffybar/toggle"

taffybarToggleInterface :: InterfaceName
taffybarToggleInterface :: InterfaceName
taffybarToggleInterface = InterfaceName
"taffybar.toggle"

toggleStateFile :: IO FilePath
toggleStateFile :: IO FilePath
toggleStateFile = (FilePath -> FilePath -> FilePath
</> FilePath
"toggle_state.dat") (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
taffyStateDir

newtype TogglesMVar = TogglesMVar (MV.MVar (M.Map Int Bool))

getTogglesVar :: TaffyIO TogglesMVar
getTogglesVar :: TaffyIO TogglesMVar
getTogglesVar = TaffyIO TogglesMVar -> TaffyIO TogglesMVar
forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault (TaffyIO TogglesMVar -> TaffyIO TogglesMVar)
-> TaffyIO TogglesMVar -> TaffyIO TogglesMVar
forall a b. (a -> b) -> a -> b
$ IO TogglesMVar -> TaffyIO TogglesMVar
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MVar (Map Int Bool) -> TogglesMVar
TogglesMVar (MVar (Map Int Bool) -> TogglesMVar)
-> IO (MVar (Map Int Bool)) -> IO TogglesMVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Int Bool -> IO (MVar (Map Int Bool))
forall a. a -> IO (MVar a)
MV.newMVar Map Int Bool
forall k a. Map k a
M.empty)

toggleBarConfigGetter :: BarConfigGetter -> BarConfigGetter
toggleBarConfigGetter :: BarConfigGetter -> BarConfigGetter
toggleBarConfigGetter BarConfigGetter
getConfigs = do
  barConfigs <- BarConfigGetter
getConfigs
  TogglesMVar enabledVar <- getTogglesVar
  numToEnabled <- lift $ MV.readMVar enabledVar
  let isEnabled Int
monNumber = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Map Int Bool -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
monNumber Map Int Bool
numToEnabled
      isConfigEnabled =
        Int -> Bool
isEnabled (Int -> Bool) -> (BarConfig -> Int) -> BarConfig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> (BarConfig -> Int32) -> BarConfig -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 (Maybe Int32 -> Int32)
-> (BarConfig -> Maybe Int32) -> BarConfig -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrutConfig -> Maybe Int32
strutMonitor (StrutConfig -> Maybe Int32)
-> (BarConfig -> StrutConfig) -> BarConfig -> Maybe Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BarConfig -> StrutConfig
strutConfig
  return $ filter isConfigEnabled barConfigs

exportTogglesInterface :: TaffyIO ()
exportTogglesInterface :: TaffyIO ()
exportTogglesInterface = do
  TogglesMVar enabledVar <- TaffyIO TogglesMVar
getTogglesVar
  ctx <- ask
  lift $ taffyStateDir >>= createDirectoryIfMissing True
  stateFile <- lift toggleStateFile
  let toggleTaffyOnMon Bool -> Bool
fn Int
mon = (TaffyIO () -> Context -> IO ()) -> Context -> TaffyIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip TaffyIO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
ctx (TaffyIO () -> IO ()) -> TaffyIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> TaffyIO ()) -> IO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ MVar (Map Int Bool) -> (Map Int Bool -> IO (Map Int Bool)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar (Map Int Bool)
enabledVar ((Map Int Bool -> IO (Map Int Bool)) -> IO ())
-> (Map Int Bool -> IO (Map Int Bool)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Int Bool
numToEnabled -> do
          let current :: Bool
current = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Map Int Bool -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
mon Map Int Bool
numToEnabled
              result :: Map Int Bool
result = Int -> Bool -> Map Int Bool -> Map Int Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
mon (Bool -> Bool
fn Bool
current) Map Int Bool
numToEnabled
          Priority -> FilePath -> IO ()
logIO Priority
DEBUG (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Toggle state before: %s, after %s"
                  (Map Int Bool -> FilePath
forall a. Show a => a -> FilePath
show Map Int Bool
numToEnabled) (Map Int Bool -> FilePath
forall a. Show a => a -> FilePath
show Map Int Bool
result)
          IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (FilePath -> FilePath -> IO ()
writeFile FilePath
stateFile (Map Int Bool -> FilePath
forall a. Show a => a -> FilePath
show Map Int Bool
result)) ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeException
e ->
            Priority -> FilePath -> IO ()
logIO Priority
WARNING (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Unable to write to toggle state file %s, error: %s"
                  (FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
stateFile) (SomeException -> FilePath
forall a. Show a => a -> FilePath
show (SomeException
e :: SomeException))
          Map Int Bool -> IO (Map Int Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Int Bool
result
        TaffyIO ()
refreshTaffyWindows
      toggleTaffy = do
        num <- MaybeT IO Int -> IO (Maybe Int)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT IO Int
getActiveMonitorNumber
        toggleTaffyOnMon not $ fromMaybe 0 num
      takeInt :: (Int -> a) -> (Int32 -> a)
      takeInt = ((Int -> a) -> (Int32 -> Int) -> Int32 -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
  client <- asks sessionDBusClient
  let interface =
        Interface
defaultInterface
        { interfaceName = taffybarToggleInterface
        , interfaceMethods =
          [ autoMethod "toggleCurrent" toggleTaffy
          , autoMethod "toggleOnMonitor" $ takeInt $ toggleTaffyOnMon not
          , autoMethod "hideOnMonitor" $
            takeInt $ toggleTaffyOnMon (const False)
          , autoMethod "showOnMonitor" $
            takeInt $ toggleTaffyOnMon (const True)
          , autoMethod "refresh" $ runReaderT refreshTaffyWindows ctx
          , autoMethod "exit" $ exitTaffybar ctx
          ]
        }
  lift $ do
    _ <- requestName client "taffybar.toggle"
       [nameAllowReplacement, nameReplaceExisting]
    export client taffybarTogglePath interface

dbusTogglesStartupHook :: TaffyIO ()
dbusTogglesStartupHook :: TaffyIO ()
dbusTogglesStartupHook = do
  TogglesMVar enabledVar <- TaffyIO TogglesMVar
getTogglesVar
  logT DEBUG "Loading toggle state"
  lift $ do
    stateFilepath <- toggleStateFile
    filepathExists <- doesFileExist stateFilepath
    mStartingMap <-
      if filepathExists
      then
        readMaybe <$> readFile stateFilepath
      else
        return Nothing
    MV.modifyMVar_ enabledVar $ const $ return $ fromMaybe M.empty mStartingMap
  logT DEBUG "Exporting toggles interface"
  exportTogglesInterface

handleDBusToggles :: TaffybarConfig -> TaffybarConfig
handleDBusToggles :: TaffybarConfig -> TaffybarConfig
handleDBusToggles TaffybarConfig
config =
  TaffybarConfig
config { getBarConfigsParam =
             toggleBarConfigGetter $ getBarConfigsParam config
         , startupHook = startupHook config >> dbusTogglesStartupHook
         }