module System.Taffybar.SimpleConfig
( SimpleTaffyConfig(..)
, Position(..)
, defaultSimpleTaffyConfig
, simpleDyreTaffybar
, simpleTaffybar
, toTaffyConfig
, toTaffybarConfig
, 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
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, ReadPrec [Position]
ReadPrec Position
Int -> ReadS Position
ReadS [Position]
(Int -> ReadS Position)
-> ReadS [Position]
-> ReadPrec Position
-> ReadPrec [Position]
-> Read Position
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Position
readsPrec :: Int -> ReadS Position
$creadList :: ReadS [Position]
readList :: ReadS [Position]
$creadPrec :: ReadPrec Position
readPrec :: ReadPrec Position
$creadListPrec :: ReadPrec [Position]
readListPrec :: ReadPrec [Position]
Read, 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, Eq Position
Eq Position =>
(Position -> Position -> Ordering)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Position)
-> (Position -> Position -> Position)
-> Ord Position
Position -> Position -> Bool
Position -> Position -> Ordering
Position -> Position -> Position
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Position -> Position -> Ordering
compare :: Position -> Position -> Ordering
$c< :: Position -> Position -> Bool
< :: Position -> Position -> Bool
$c<= :: Position -> Position -> Bool
<= :: Position -> Position -> Bool
$c> :: Position -> Position -> Bool
> :: Position -> Position -> Bool
$c>= :: Position -> Position -> Bool
>= :: Position -> Position -> Bool
$cmax :: Position -> Position -> Position
max :: Position -> Position -> Position
$cmin :: Position -> Position -> Position
min :: Position -> Position -> Position
Ord, Int -> Position
Position -> Int
Position -> [Position]
Position -> Position
Position -> Position -> [Position]
Position -> Position -> Position -> [Position]
(Position -> Position)
-> (Position -> Position)
-> (Int -> Position)
-> (Position -> Int)
-> (Position -> [Position])
-> (Position -> Position -> [Position])
-> (Position -> Position -> [Position])
-> (Position -> Position -> Position -> [Position])
-> Enum Position
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Position -> Position
succ :: Position -> Position
$cpred :: Position -> Position
pred :: Position -> Position
$ctoEnum :: Int -> Position
toEnum :: Int -> Position
$cfromEnum :: Position -> Int
fromEnum :: Position -> Int
$cenumFrom :: Position -> [Position]
enumFrom :: Position -> [Position]
$cenumFromThen :: Position -> Position -> [Position]
enumFromThen :: Position -> Position -> [Position]
$cenumFromTo :: Position -> Position -> [Position]
enumFromTo :: Position -> Position -> [Position]
$cenumFromThenTo :: Position -> Position -> Position -> [Position]
enumFromThenTo :: Position -> Position -> Position -> [Position]
Enum, Position
Position -> Position -> Bounded Position
forall a. a -> a -> Bounded a
$cminBound :: Position
minBound :: Position
$cmaxBound :: Position
maxBound :: Position
Bounded)
data SimpleTaffyConfig = SimpleTaffyConfig
{
SimpleTaffyConfig -> TaffyIO [Int]
monitorsAction :: TaffyIO [Int]
, SimpleTaffyConfig -> StrutSize
barHeight :: StrutSize
, SimpleTaffyConfig -> Int
barPadding :: Int
, SimpleTaffyConfig -> Position
barPosition :: Position
, SimpleTaffyConfig -> Int
widgetSpacing :: Int
, SimpleTaffyConfig -> [TaffyIO Widget]
startWidgets :: [TaffyIO Gtk.Widget]
, SimpleTaffyConfig -> [TaffyIO Widget]
centerWidgets :: [TaffyIO Gtk.Widget]
, SimpleTaffyConfig -> [TaffyIO Widget]
endWidgets :: [TaffyIO Gtk.Widget]
, SimpleTaffyConfig -> [String]
cssPaths :: [FilePath]
, SimpleTaffyConfig -> TaffyIO ()
startupHook :: TaffyIO ()
}
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
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 = height
, strutYPadding = fromIntegral padding
, strutXPadding = fromIntegral padding
, strutAlignment = Center
, strutMonitor = Just $ fromIntegral monitor
, strutPosition =
case 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)])
{-# DEPRECATED toTaffyConfig "Use toTaffybarConfig instead" #-}
toTaffyConfig :: SimpleTaffyConfig -> BC.TaffybarConfig
toTaffyConfig :: SimpleTaffyConfig -> TaffybarConfig
toTaffyConfig = SimpleTaffyConfig -> TaffybarConfig
toTaffybarConfig
toTaffybarConfig :: SimpleTaffyConfig -> BC.TaffybarConfig
toTaffybarConfig :: SimpleTaffyConfig -> TaffybarConfig
toTaffybarConfig SimpleTaffyConfig
conf =
TaffybarConfig
forall a. Default a => a
def
{ BC.getBarConfigsParam = configGetter
, BC.cssPaths = cssPaths conf
, BC.startupHook = startupHook conf
}
where
configGetter :: ReaderT Context IO [BarConfig]
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] -> ReaderT Context IO [BarConfig]
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] -> ReaderT Context IO [BarConfig])
-> IO [BarConfig] -> ReaderT Context IO [BarConfig]
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
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
toTaffybarConfig SimpleTaffyConfig
conf
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
toTaffybarConfig 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))
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]
usePrimaryMonitor :: TaffyIO [Int]
usePrimaryMonitor :: TaffyIO [Int]
usePrimaryMonitor =
Int -> [Int]
forall a. a -> [a]
singleton (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 (DisplayName -> X11Property (Maybe Int) -> IO (Maybe Int)
forall a. DisplayName -> X11Property a -> IO a
withX11Context DisplayName
forall a. Default a => a
def X11Property (Maybe Int)
getPrimaryOutputNumber)