-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.SimpleConfig
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This module defines a simpler, but less flexible config system than the one
-- offered in "System.Taffybar.Context".
-----------------------------------------------------------------------------
module System.Taffybar.SimpleConfig
  ( SimpleTaffyConfig(..)
  , Position(..)
  , defaultSimpleTaffyConfig
  , simpleDyreTaffybar
  , simpleTaffybar
  , toTaffyConfig
  , useAllMonitors
  , usePrimaryMonitor
  , StrutSize(..)
  ) where

import qualified Control.Concurrent.MVar as MV
import           Control.Monad
import           Control.Monad.Trans.Class
import           Data.Default (Default(..))
import           Data.List
import           Data.Maybe
import           Data.Unique
import qualified GI.Gtk as Gtk
import           GI.Gdk
import           Graphics.UI.GIGtkStrut
import           System.Taffybar.Information.X11DesktopInfo
import           System.Taffybar
import qualified System.Taffybar.Context as BC (BarConfig(..), TaffybarConfig(..))
import           System.Taffybar.Context hiding (TaffybarConfig(..), BarConfig(..))
import           System.Taffybar.Util

-- | An ADT representing the edge of the monitor along which taffybar should be
-- displayed.
data Position = Top | Bottom deriving (Int -> Position -> ShowS
[Position] -> ShowS
Position -> String
(Int -> Position -> ShowS)
-> (Position -> String) -> ([Position] -> ShowS) -> Show Position
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Position -> ShowS
showsPrec :: Int -> Position -> ShowS
$cshow :: Position -> String
show :: Position -> String
$cshowList :: [Position] -> ShowS
showList :: [Position] -> ShowS
Show, Position -> Position -> Bool
(Position -> Position -> Bool)
-> (Position -> Position -> Bool) -> Eq Position
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
/= :: Position -> Position -> Bool
Eq)

-- | A configuration object whose interface is simpler than that of
-- 'TaffybarConfig'. Unless you have a good reason to use taffybar's more
-- advanced interface, you should stick to using this one.
data SimpleTaffyConfig = SimpleTaffyConfig
  {
  -- | The monitor number to put the bar on (default: 'usePrimaryMonitor')
    SimpleTaffyConfig -> TaffyIO [Int]
monitorsAction :: TaffyIO [Int]
  -- | Number of pixels to reserve for the bar (default: 30)
  , SimpleTaffyConfig -> StrutSize
barHeight :: StrutSize
  -- | Number of additional pixels to reserve for the bar strut (default: 0)
  , SimpleTaffyConfig -> Int
barPadding :: Int
  -- | The position of the bar on the screen (default: 'Top')
  , SimpleTaffyConfig -> Position
barPosition :: Position
  -- | The number of pixels between widgets (default: 5)
  , SimpleTaffyConfig -> Int
widgetSpacing :: Int
  -- | Widget constructors whose outputs are placed at the beginning of the bar
  , SimpleTaffyConfig -> [TaffyIO Widget]
startWidgets :: [TaffyIO Gtk.Widget]
  -- | Widget constructors whose outputs are placed in the center of the bar
  , SimpleTaffyConfig -> [TaffyIO Widget]
centerWidgets :: [TaffyIO Gtk.Widget]
  -- | Widget constructors whose outputs are placed at the end of the bar
  , SimpleTaffyConfig -> [TaffyIO Widget]
endWidgets :: [TaffyIO Gtk.Widget]
  -- | List of paths to CSS stylesheets that should be loaded at startup.
  , SimpleTaffyConfig -> [String]
cssPaths :: [FilePath]
  -- | Hook to run at taffybar startup.
  , SimpleTaffyConfig -> TaffyIO ()
startupHook :: TaffyIO ()
  }

-- | Sensible defaults for most of the fields of 'SimpleTaffyConfig'. You'll
-- need to specify the widgets you want in the bar with 'startWidgets',
-- 'centerWidgets' and 'endWidgets'.
defaultSimpleTaffyConfig :: SimpleTaffyConfig
defaultSimpleTaffyConfig :: SimpleTaffyConfig
defaultSimpleTaffyConfig = SimpleTaffyConfig
  { monitorsAction :: TaffyIO [Int]
monitorsAction = TaffyIO [Int]
useAllMonitors
  , barHeight :: StrutSize
barHeight = Rational -> StrutSize
ScreenRatio (Rational -> StrutSize) -> Rational -> StrutSize
forall a b. (a -> b) -> a -> b
$ Rational
1 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
27
  , barPadding :: Int
barPadding = Int
0
  , barPosition :: Position
barPosition = Position
Top
  , widgetSpacing :: Int
widgetSpacing = Int
5
  , startWidgets :: [TaffyIO Widget]
startWidgets = []
  , centerWidgets :: [TaffyIO Widget]
centerWidgets = []
  , endWidgets :: [TaffyIO Widget]
endWidgets = []
  , cssPaths :: [String]
cssPaths = []
  , startupHook :: TaffyIO ()
startupHook = () -> TaffyIO ()
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  }

instance Default SimpleTaffyConfig where
  def :: SimpleTaffyConfig
def = SimpleTaffyConfig
defaultSimpleTaffyConfig

-- | Convert a 'SimpleTaffyConfig' into a 'StrutConfig' that can be used with
-- gtk-strut.
toStrutConfig :: SimpleTaffyConfig -> Int -> StrutConfig
toStrutConfig :: SimpleTaffyConfig -> Int -> StrutConfig
toStrutConfig SimpleTaffyConfig { barHeight :: SimpleTaffyConfig -> StrutSize
barHeight = StrutSize
height
                                , barPadding :: SimpleTaffyConfig -> Int
barPadding = Int
padding
                                , barPosition :: SimpleTaffyConfig -> Position
barPosition = Position
pos
                                } Int
monitor =
  StrutConfig
defaultStrutConfig
  { strutHeight :: StrutSize
strutHeight = StrutSize
height
  , strutYPadding :: Int32
strutYPadding = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
padding
  , strutXPadding :: Int32
strutXPadding = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
padding
  , strutAlignment :: StrutAlignment
strutAlignment = StrutAlignment
Center
  , strutMonitor :: Maybe Int32
strutMonitor = Int32 -> Maybe Int32
forall a. a -> Maybe a
Just (Int32 -> Maybe Int32) -> Int32 -> Maybe Int32
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
monitor
  , strutPosition :: StrutPosition
strutPosition =
      case Position
pos of
        Position
Top -> StrutPosition
TopPos
        Position
Bottom -> StrutPosition
BottomPos
  }

toBarConfig :: SimpleTaffyConfig -> Int -> IO BC.BarConfig
toBarConfig :: SimpleTaffyConfig -> Int -> IO BarConfig
toBarConfig SimpleTaffyConfig
config Int
monitor = do
  let strutConfig :: StrutConfig
strutConfig = SimpleTaffyConfig -> Int -> StrutConfig
toStrutConfig SimpleTaffyConfig
config Int
monitor
  Unique
barId <- IO Unique
newUnique
  BarConfig -> IO BarConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    BC.BarConfig
    { strutConfig :: StrutConfig
BC.strutConfig = StrutConfig
strutConfig
    , widgetSpacing :: Int32
BC.widgetSpacing = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ SimpleTaffyConfig -> Int
widgetSpacing SimpleTaffyConfig
config
    , startWidgets :: [TaffyIO Widget]
BC.startWidgets = SimpleTaffyConfig -> [TaffyIO Widget]
startWidgets SimpleTaffyConfig
config
    , centerWidgets :: [TaffyIO Widget]
BC.centerWidgets = SimpleTaffyConfig -> [TaffyIO Widget]
centerWidgets SimpleTaffyConfig
config
    , endWidgets :: [TaffyIO Widget]
BC.endWidgets = SimpleTaffyConfig -> [TaffyIO Widget]
endWidgets SimpleTaffyConfig
config
    , barId :: Unique
BC.barId = Unique
barId
    }

newtype SimpleBarConfigs = SimpleBarConfigs (MV.MVar [(Int, BC.BarConfig)])

-- | Convert a 'SimpleTaffyConfig' into a 'BC.TaffybarConfig' that can be used
-- with 'startTaffybar' or 'dyreTaffybar'.
toTaffyConfig :: SimpleTaffyConfig -> BC.TaffybarConfig
toTaffyConfig :: SimpleTaffyConfig -> TaffybarConfig
toTaffyConfig SimpleTaffyConfig
conf =
    TaffybarConfig
forall a. Default a => a
def
    { getBarConfigsParam :: BarConfigGetter
BC.getBarConfigsParam = BarConfigGetter
configGetter
    , cssPaths :: [String]
BC.cssPaths = SimpleTaffyConfig -> [String]
cssPaths SimpleTaffyConfig
conf
    , startupHook :: TaffyIO ()
BC.startupHook = SimpleTaffyConfig -> TaffyIO ()
startupHook SimpleTaffyConfig
conf
    }
  where
    configGetter :: BarConfigGetter
configGetter = do
      SimpleBarConfigs MVar [(Int, BarConfig)]
configsVar <-
        Taffy IO SimpleBarConfigs -> Taffy IO SimpleBarConfigs
forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault (Taffy IO SimpleBarConfigs -> Taffy IO SimpleBarConfigs)
-> Taffy IO SimpleBarConfigs -> Taffy IO SimpleBarConfigs
forall a b. (a -> b) -> a -> b
$ IO SimpleBarConfigs -> Taffy IO SimpleBarConfigs
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 [(Int, BarConfig)] -> SimpleBarConfigs
SimpleBarConfigs (MVar [(Int, BarConfig)] -> SimpleBarConfigs)
-> IO (MVar [(Int, BarConfig)]) -> IO SimpleBarConfigs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, BarConfig)] -> IO (MVar [(Int, BarConfig)])
forall a. a -> IO (MVar a)
MV.newMVar [])
      [Int]
monitorNumbers <- SimpleTaffyConfig -> TaffyIO [Int]
monitorsAction SimpleTaffyConfig
conf

      let lookupWithIndex :: [(a, b)] -> a -> (a, Maybe b)
lookupWithIndex [(a, b)]
barConfigs a
monitorNumber =
            (a
monitorNumber, a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
monitorNumber [(a, b)]
barConfigs)

          lookupAndUpdate :: [(Int, BarConfig)] -> IO ([(Int, BarConfig)], [BarConfig])
lookupAndUpdate [(Int, BarConfig)]
barConfigs = do

            let ([(Int, Maybe BarConfig)]
alreadyPresent, [(Int, Maybe BarConfig)]
toCreate) =
                  ((Int, Maybe BarConfig) -> Bool)
-> [(Int, Maybe BarConfig)]
-> ([(Int, Maybe BarConfig)], [(Int, Maybe BarConfig)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Maybe BarConfig -> Bool
forall a. Maybe a -> Bool
isJust (Maybe BarConfig -> Bool)
-> ((Int, Maybe BarConfig) -> Maybe BarConfig)
-> (Int, Maybe BarConfig)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Maybe BarConfig) -> Maybe BarConfig
forall a b. (a, b) -> b
snd) ([(Int, Maybe BarConfig)]
 -> ([(Int, Maybe BarConfig)], [(Int, Maybe BarConfig)]))
-> [(Int, Maybe BarConfig)]
-> ([(Int, Maybe BarConfig)], [(Int, Maybe BarConfig)])
forall a b. (a -> b) -> a -> b
$
                  (Int -> (Int, Maybe BarConfig))
-> [Int] -> [(Int, Maybe BarConfig)]
forall a b. (a -> b) -> [a] -> [b]
map ([(Int, BarConfig)] -> Int -> (Int, Maybe BarConfig)
forall {a} {b}. Eq a => [(a, b)] -> a -> (a, Maybe b)
lookupWithIndex [(Int, BarConfig)]
barConfigs) [Int]
monitorNumbers
                alreadyPresentConfigs :: [BarConfig]
alreadyPresentConfigs = ((Int, Maybe BarConfig) -> Maybe BarConfig)
-> [(Int, Maybe BarConfig)] -> [BarConfig]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Int, Maybe BarConfig) -> Maybe BarConfig
forall a b. (a, b) -> b
snd [(Int, Maybe BarConfig)]
alreadyPresent

            [(Int, BarConfig)]
newlyCreated <-
              ((Int, Maybe BarConfig) -> IO (Int, BarConfig))
-> [(Int, Maybe BarConfig)] -> IO [(Int, BarConfig)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Int -> IO Int)
-> (Int -> IO BarConfig) -> Int -> IO (Int, BarConfig)
forall (m :: * -> *) c a b.
Monad m =>
(c -> m a) -> (c -> m b) -> c -> m (a, b)
forkM Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimpleTaffyConfig -> Int -> IO BarConfig
toBarConfig SimpleTaffyConfig
conf) (Int -> IO (Int, BarConfig))
-> ((Int, Maybe BarConfig) -> Int)
-> (Int, Maybe BarConfig)
-> IO (Int, BarConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Maybe BarConfig) -> Int
forall a b. (a, b) -> a
fst) [(Int, Maybe BarConfig)]
toCreate
            let result :: [BarConfig]
result = ((Int, BarConfig) -> BarConfig)
-> [(Int, BarConfig)] -> [BarConfig]
forall a b. (a -> b) -> [a] -> [b]
map (Int, BarConfig) -> BarConfig
forall a b. (a, b) -> b
snd [(Int, BarConfig)]
newlyCreated [BarConfig] -> [BarConfig] -> [BarConfig]
forall a. [a] -> [a] -> [a]
++ [BarConfig]
alreadyPresentConfigs
            ([(Int, BarConfig)], [BarConfig])
-> IO ([(Int, BarConfig)], [BarConfig])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, BarConfig)]
barConfigs [(Int, BarConfig)] -> [(Int, BarConfig)] -> [(Int, BarConfig)]
forall a. [a] -> [a] -> [a]
++ [(Int, BarConfig)]
newlyCreated, [BarConfig]
result)

      IO [BarConfig] -> BarConfigGetter
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 [BarConfig] -> BarConfigGetter)
-> IO [BarConfig] -> BarConfigGetter
forall a b. (a -> b) -> a -> b
$ MVar [(Int, BarConfig)]
-> ([(Int, BarConfig)] -> IO ([(Int, BarConfig)], [BarConfig]))
-> IO [BarConfig]
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MV.modifyMVar MVar [(Int, BarConfig)]
configsVar [(Int, BarConfig)] -> IO ([(Int, BarConfig)], [BarConfig])
lookupAndUpdate

-- | Start taffybar using dyre with a 'SimpleTaffybarConfig'.
simpleDyreTaffybar :: SimpleTaffyConfig -> IO ()
simpleDyreTaffybar :: SimpleTaffyConfig -> IO ()
simpleDyreTaffybar SimpleTaffyConfig
conf = TaffybarConfig -> IO ()
dyreTaffybar (TaffybarConfig -> IO ()) -> TaffybarConfig -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleTaffyConfig -> TaffybarConfig
toTaffyConfig SimpleTaffyConfig
conf

-- | Start taffybar with a 'SimpleTaffybarConfig'.
simpleTaffybar :: SimpleTaffyConfig -> IO ()
simpleTaffybar :: SimpleTaffyConfig -> IO ()
simpleTaffybar SimpleTaffyConfig
conf = TaffybarConfig -> IO ()
startTaffybar (TaffybarConfig -> IO ()) -> TaffybarConfig -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleTaffyConfig -> TaffybarConfig
toTaffyConfig SimpleTaffyConfig
conf

getMonitorCount :: IO Int
getMonitorCount :: IO Int
getMonitorCount =
  Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> IO Int32 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO (Maybe Screen)
forall (m :: * -> *). (HasCallStack, MonadIO m) => m (Maybe Screen)
screenGetDefault IO (Maybe Screen) -> (Maybe Screen -> IO Int32) -> IO Int32
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Int32 -> (Screen -> IO Int32) -> Maybe Screen -> IO Int32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int32 -> IO Int32
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
0)
                    (Screen -> IO Display
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsScreen a) =>
a -> m Display
screenGetDisplay (Screen -> IO Display)
-> (Display -> IO Int32) -> Screen -> IO Int32
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Display -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> m Int32
displayGetNMonitors))

-- | Supply this value for 'monitorsAction' to display the taffybar window on
-- all monitors.
useAllMonitors :: TaffyIO [Int]
useAllMonitors :: TaffyIO [Int]
useAllMonitors = IO [Int] -> TaffyIO [Int]
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 [Int] -> TaffyIO [Int]) -> IO [Int] -> TaffyIO [Int]
forall a b. (a -> b) -> a -> b
$ do
  Int
count <- IO Int
getMonitorCount
  [Int] -> IO [Int]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Int
0..Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

-- | Supply this value for 'monitorsAction' to display the taffybar window only
-- on the primary monitor.
usePrimaryMonitor :: TaffyIO [Int]
usePrimaryMonitor :: TaffyIO [Int]
usePrimaryMonitor =
  Int -> [Int]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Int]) -> (Maybe Int -> Int) -> Maybe Int -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> [Int])
-> ReaderT Context IO (Maybe Int) -> TaffyIO [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe Int) -> ReaderT Context IO (Maybe Int)
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 (X11Property (Maybe Int) -> IO (Maybe Int)
forall a. X11Property a -> IO a
withDefaultCtx X11Property (Maybe Int)
getPrimaryOutputNumber)