module Graphics.UI.GIGtkStrut
( defaultStrutConfig
, StrutPosition(..)
, StrutSize(..)
, StrutAlignment(..)
, StrutConfig(..)
, buildStrutWindow
, setupStrutWindow
) where
import Control.Monad
import Control.Monad.Fail (MonadFail)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Default
import Data.Int
import Data.Maybe
import qualified Data.Text as T
import qualified GI.Gdk as Gdk
import qualified GI.Gtk as Gtk
import Graphics.UI.EWMHStrut
import System.Log.Logger
import Text.Printf
strutLog :: MonadIO m => Priority -> String -> m ()
strutLog :: forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
strutLog Priority
p String
s = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"Graphics.UI.GIGtkStrut" Priority
p String
s
data StrutPosition
= TopPos | BottomPos | LeftPos | RightPos
deriving (Int -> StrutPosition -> ShowS
[StrutPosition] -> ShowS
StrutPosition -> String
(Int -> StrutPosition -> ShowS)
-> (StrutPosition -> String)
-> ([StrutPosition] -> ShowS)
-> Show StrutPosition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StrutPosition -> ShowS
showsPrec :: Int -> StrutPosition -> ShowS
$cshow :: StrutPosition -> String
show :: StrutPosition -> String
$cshowList :: [StrutPosition] -> ShowS
showList :: [StrutPosition] -> ShowS
Show, ReadPrec [StrutPosition]
ReadPrec StrutPosition
Int -> ReadS StrutPosition
ReadS [StrutPosition]
(Int -> ReadS StrutPosition)
-> ReadS [StrutPosition]
-> ReadPrec StrutPosition
-> ReadPrec [StrutPosition]
-> Read StrutPosition
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS StrutPosition
readsPrec :: Int -> ReadS StrutPosition
$creadList :: ReadS [StrutPosition]
readList :: ReadS [StrutPosition]
$creadPrec :: ReadPrec StrutPosition
readPrec :: ReadPrec StrutPosition
$creadListPrec :: ReadPrec [StrutPosition]
readListPrec :: ReadPrec [StrutPosition]
Read, StrutPosition -> StrutPosition -> Bool
(StrutPosition -> StrutPosition -> Bool)
-> (StrutPosition -> StrutPosition -> Bool) -> Eq StrutPosition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StrutPosition -> StrutPosition -> Bool
== :: StrutPosition -> StrutPosition -> Bool
$c/= :: StrutPosition -> StrutPosition -> Bool
/= :: StrutPosition -> StrutPosition -> Bool
Eq)
data StrutAlignment
= Beginning | Center | End
deriving (Int -> StrutAlignment -> ShowS
[StrutAlignment] -> ShowS
StrutAlignment -> String
(Int -> StrutAlignment -> ShowS)
-> (StrutAlignment -> String)
-> ([StrutAlignment] -> ShowS)
-> Show StrutAlignment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StrutAlignment -> ShowS
showsPrec :: Int -> StrutAlignment -> ShowS
$cshow :: StrutAlignment -> String
show :: StrutAlignment -> String
$cshowList :: [StrutAlignment] -> ShowS
showList :: [StrutAlignment] -> ShowS
Show, ReadPrec [StrutAlignment]
ReadPrec StrutAlignment
Int -> ReadS StrutAlignment
ReadS [StrutAlignment]
(Int -> ReadS StrutAlignment)
-> ReadS [StrutAlignment]
-> ReadPrec StrutAlignment
-> ReadPrec [StrutAlignment]
-> Read StrutAlignment
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS StrutAlignment
readsPrec :: Int -> ReadS StrutAlignment
$creadList :: ReadS [StrutAlignment]
readList :: ReadS [StrutAlignment]
$creadPrec :: ReadPrec StrutAlignment
readPrec :: ReadPrec StrutAlignment
$creadListPrec :: ReadPrec [StrutAlignment]
readListPrec :: ReadPrec [StrutAlignment]
Read, StrutAlignment -> StrutAlignment -> Bool
(StrutAlignment -> StrutAlignment -> Bool)
-> (StrutAlignment -> StrutAlignment -> Bool) -> Eq StrutAlignment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StrutAlignment -> StrutAlignment -> Bool
== :: StrutAlignment -> StrutAlignment -> Bool
$c/= :: StrutAlignment -> StrutAlignment -> Bool
/= :: StrutAlignment -> StrutAlignment -> Bool
Eq)
data StrutSize
= ExactSize Int32 | ScreenRatio Rational
deriving (Int -> StrutSize -> ShowS
[StrutSize] -> ShowS
StrutSize -> String
(Int -> StrutSize -> ShowS)
-> (StrutSize -> String)
-> ([StrutSize] -> ShowS)
-> Show StrutSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StrutSize -> ShowS
showsPrec :: Int -> StrutSize -> ShowS
$cshow :: StrutSize -> String
show :: StrutSize -> String
$cshowList :: [StrutSize] -> ShowS
showList :: [StrutSize] -> ShowS
Show, ReadPrec [StrutSize]
ReadPrec StrutSize
Int -> ReadS StrutSize
ReadS [StrutSize]
(Int -> ReadS StrutSize)
-> ReadS [StrutSize]
-> ReadPrec StrutSize
-> ReadPrec [StrutSize]
-> Read StrutSize
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS StrutSize
readsPrec :: Int -> ReadS StrutSize
$creadList :: ReadS [StrutSize]
readList :: ReadS [StrutSize]
$creadPrec :: ReadPrec StrutSize
readPrec :: ReadPrec StrutSize
$creadListPrec :: ReadPrec [StrutSize]
readListPrec :: ReadPrec [StrutSize]
Read, StrutSize -> StrutSize -> Bool
(StrutSize -> StrutSize -> Bool)
-> (StrutSize -> StrutSize -> Bool) -> Eq StrutSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StrutSize -> StrutSize -> Bool
== :: StrutSize -> StrutSize -> Bool
$c/= :: StrutSize -> StrutSize -> Bool
/= :: StrutSize -> StrutSize -> Bool
Eq)
data StrutConfig = StrutConfig
{ StrutConfig -> StrutSize
strutWidth :: StrutSize
, StrutConfig -> StrutSize
strutHeight :: StrutSize
, StrutConfig -> Int32
strutXPadding :: Int32
, StrutConfig -> Int32
strutYPadding :: Int32
, StrutConfig -> Maybe Int32
strutMonitor :: Maybe Int32
, StrutConfig -> StrutPosition
strutPosition :: StrutPosition
, StrutConfig -> StrutAlignment
strutAlignment :: StrutAlignment
, StrutConfig -> Maybe Text
strutDisplayName :: Maybe T.Text
} deriving (Int -> StrutConfig -> ShowS
[StrutConfig] -> ShowS
StrutConfig -> String
(Int -> StrutConfig -> ShowS)
-> (StrutConfig -> String)
-> ([StrutConfig] -> ShowS)
-> Show StrutConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StrutConfig -> ShowS
showsPrec :: Int -> StrutConfig -> ShowS
$cshow :: StrutConfig -> String
show :: StrutConfig -> String
$cshowList :: [StrutConfig] -> ShowS
showList :: [StrutConfig] -> ShowS
Show, StrutConfig -> StrutConfig -> Bool
(StrutConfig -> StrutConfig -> Bool)
-> (StrutConfig -> StrutConfig -> Bool) -> Eq StrutConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StrutConfig -> StrutConfig -> Bool
== :: StrutConfig -> StrutConfig -> Bool
$c/= :: StrutConfig -> StrutConfig -> Bool
/= :: StrutConfig -> StrutConfig -> Bool
Eq)
defaultStrutConfig :: StrutConfig
defaultStrutConfig = StrutConfig
{ strutWidth :: StrutSize
strutWidth = Rational -> StrutSize
ScreenRatio Rational
1
, strutHeight :: StrutSize
strutHeight = Rational -> StrutSize
ScreenRatio Rational
1
, strutXPadding :: Int32
strutXPadding = Int32
0
, strutYPadding :: Int32
strutYPadding = Int32
0
, strutMonitor :: Maybe Int32
strutMonitor = Maybe Int32
forall a. Maybe a
Nothing
, strutPosition :: StrutPosition
strutPosition = StrutPosition
TopPos
, strutAlignment :: StrutAlignment
strutAlignment = StrutAlignment
Beginning
, strutDisplayName :: Maybe Text
strutDisplayName = Maybe Text
forall a. Maybe a
Nothing
}
instance Default StrutConfig where
def :: StrutConfig
def =
StrutConfig
{ strutWidth :: StrutSize
strutWidth = Rational -> StrutSize
ScreenRatio Rational
1
, strutHeight :: StrutSize
strutHeight = Rational -> StrutSize
ScreenRatio Rational
1
, strutXPadding :: Int32
strutXPadding = Int32
0
, strutYPadding :: Int32
strutYPadding = Int32
0
, strutMonitor :: Maybe Int32
strutMonitor = Maybe Int32
forall a. Maybe a
Nothing
, strutPosition :: StrutPosition
strutPosition = StrutPosition
TopPos
, strutAlignment :: StrutAlignment
strutAlignment = StrutAlignment
Beginning
, strutDisplayName :: Maybe Text
strutDisplayName = Maybe Text
forall a. Maybe a
Nothing
}
buildStrutWindow :: (MonadFail m, MonadIO m) => StrutConfig -> m Gtk.Window
buildStrutWindow :: forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
StrutConfig -> m Window
buildStrutWindow StrutConfig
config = do
Window
window <- WindowType -> m Window
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
WindowType -> m Window
Gtk.windowNew WindowType
Gtk.WindowTypeToplevel
StrutConfig -> Window -> m ()
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
StrutConfig -> Window -> m ()
setupStrutWindow StrutConfig
config Window
window
Window -> m Window
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Window
window
setupStrutWindow :: (MonadFail m, MonadIO m) => StrutConfig -> Gtk.Window -> m ()
setupStrutWindow :: forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
StrutConfig -> Window -> m ()
setupStrutWindow StrutConfig
{ strutWidth :: StrutConfig -> StrutSize
strutWidth = StrutSize
widthSize
, strutHeight :: StrutConfig -> StrutSize
strutHeight = StrutSize
heightSize
, strutXPadding :: StrutConfig -> Int32
strutXPadding = Int32
xpadding
, strutYPadding :: StrutConfig -> Int32
strutYPadding = Int32
ypadding
, strutMonitor :: StrutConfig -> Maybe Int32
strutMonitor = Maybe Int32
monitorNumber
, strutPosition :: StrutConfig -> StrutPosition
strutPosition = StrutPosition
position
, strutAlignment :: StrutConfig -> StrutAlignment
strutAlignment = StrutAlignment
alignment
, strutDisplayName :: StrutConfig -> Maybe Text
strutDisplayName = Maybe Text
displayName
} Window
window = do
Priority -> String -> m ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
strutLog Priority
DEBUG String
"Starting strut window setup"
Just Display
display <- m (Maybe Display)
-> (Text -> m (Maybe Display)) -> Maybe Text -> m (Maybe Display)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (Maybe Display)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m (Maybe Display)
Gdk.displayGetDefault Text -> m (Maybe Display)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> m (Maybe Display)
Gdk.displayOpen Maybe Text
displayName
Just Monitor
monitor <- m (Maybe Monitor)
-> (Int32 -> m (Maybe Monitor)) -> Maybe Int32 -> m (Maybe Monitor)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Display -> m (Maybe Monitor)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> m (Maybe Monitor)
Gdk.displayGetPrimaryMonitor Display
display)
(Display -> Int32 -> m (Maybe Monitor)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> Int32 -> m (Maybe Monitor)
Gdk.displayGetMonitor Display
display) Maybe Int32
monitorNumber
Screen
screen <- Display -> m Screen
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> m Screen
Gdk.displayGetDefaultScreen Display
display
Int32
monitorCount <- Display -> m Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> m Int32
Gdk.displayGetNMonitors Display
display
[Monitor]
allMonitors <- [Maybe Monitor] -> [Monitor]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Monitor] -> [Monitor]) -> m [Maybe Monitor] -> m [Monitor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int32 -> m (Maybe Monitor)) -> [Int32] -> m [Maybe Monitor]
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 (Display -> Int32 -> m (Maybe Monitor)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> Int32 -> m (Maybe Monitor)
Gdk.displayGetMonitor Display
display)
[Int32
0..(Int32
monitorCountInt32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
-Int32
1)]
[Rectangle]
allGeometries <- (Monitor -> m Rectangle) -> [Monitor] -> m [Rectangle]
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 Monitor -> m Rectangle
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMonitor a) =>
a -> m Rectangle
Gdk.monitorGetGeometry [Monitor]
allMonitors
let getFullY :: Rectangle -> f Int32
getFullY Rectangle
geometry = Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
(+) (Int32 -> Int32 -> Int32) -> f Int32 -> f (Int32 -> Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rectangle -> f Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleY Rectangle
geometry
f (Int32 -> Int32) -> f Int32 -> f Int32
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rectangle -> f Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleHeight Rectangle
geometry
getFullX :: Rectangle -> f Int32
getFullX Rectangle
geometry = Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
(+) (Int32 -> Int32 -> Int32) -> f Int32 -> f (Int32 -> Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rectangle -> f Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleX Rectangle
geometry
f (Int32 -> Int32) -> f Int32 -> f Int32
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rectangle -> f Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleWidth Rectangle
geometry
Int32
screenWidth <- [Int32] -> Int32
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int32] -> Int32) -> m [Int32] -> m Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Rectangle -> m Int32) -> [Rectangle] -> m [Int32]
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 Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
getFullX [Rectangle]
allGeometries
Int32
screenHeight <- [Int32] -> Int32
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int32] -> Int32) -> m [Int32] -> m Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Rectangle -> m Int32) -> [Rectangle] -> m [Int32]
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 Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
getFullY [Rectangle]
allGeometries
Geometry
geometry <- m Geometry
forall (m :: * -> *). MonadIO m => m Geometry
Gdk.newZeroGeometry
Rectangle
monitorGeometry <- Monitor -> m Rectangle
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMonitor a) =>
a -> m Rectangle
Gdk.monitorGetGeometry Monitor
monitor
Int32
monitorScaleFactor <- Monitor -> m Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMonitor a) =>
a -> m Int32
Gdk.monitorGetScaleFactor Monitor
monitor
Int32
monitorWidth <- Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleWidth Rectangle
monitorGeometry
Int32
monitorHeight <- Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleHeight Rectangle
monitorGeometry
Int32
monitorX <- Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleX Rectangle
monitorGeometry
Int32
monitorY <- Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleY Rectangle
monitorGeometry
let width :: Int32
width =
case StrutSize
widthSize of
ExactSize Int32
w -> Int32
w
ScreenRatio Rational
p ->
Rational -> Int32
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Int32) -> Rational -> Int32
forall a b. (a -> b) -> a -> b
$ Rational
p Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Int32 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
monitorWidth Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- (Int32
2 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
xpadding))
height :: Int32
height =
case StrutSize
heightSize of
ExactSize Int32
h -> Int32
h
ScreenRatio Rational
p ->
Rational -> Int32
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Int32) -> Rational -> Int32
forall a b. (a -> b) -> a -> b
$ Rational
p Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Int32 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
monitorHeight Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- (Int32
2 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
ypadding))
Geometry -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => Geometry -> Int32 -> m ()
Gdk.setGeometryBaseWidth Geometry
geometry Int32
width
Geometry -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => Geometry -> Int32 -> m ()
Gdk.setGeometryBaseHeight Geometry
geometry Int32
height
Geometry -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => Geometry -> Int32 -> m ()
Gdk.setGeometryMinWidth Geometry
geometry Int32
width
Geometry -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => Geometry -> Int32 -> m ()
Gdk.setGeometryMinHeight Geometry
geometry Int32
height
Geometry -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => Geometry -> Int32 -> m ()
Gdk.setGeometryMaxWidth Geometry
geometry Int32
width
Geometry -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => Geometry -> Int32 -> m ()
Gdk.setGeometryMaxHeight Geometry
geometry Int32
height
Window -> Maybe Window -> Maybe Geometry -> [WindowHints] -> m ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsWidget b) =>
a -> Maybe b -> Maybe Geometry -> [WindowHints] -> m ()
Gtk.windowSetGeometryHints Window
window (Maybe Window
forall a. Maybe a
Nothing :: Maybe Gtk.Window)
(Geometry -> Maybe Geometry
forall a. a -> Maybe a
Just Geometry
geometry) [WindowHints]
allHints
let paddedHeight :: Int32
paddedHeight = Int32
height Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
2 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
ypadding
paddedWidth :: Int32
paddedWidth = Int32
width Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
2 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
xpadding
getAlignedPos :: a -> a -> a -> a -> a
getAlignedPos a
dimensionPos a
dpadding a
monitorSize a
barSize =
a
dimensionPos a -> a -> a
forall a. Num a => a -> a -> a
+
case StrutAlignment
alignment of
StrutAlignment
Beginning -> a
dpadding
StrutAlignment
Center -> (a
monitorSize a -> a -> a
forall a. Num a => a -> a -> a
- a
barSize) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
2
StrutAlignment
End -> a
monitorSize a -> a -> a
forall a. Num a => a -> a -> a
- a
barSize a -> a -> a
forall a. Num a => a -> a -> a
- a
dpadding
xAligned :: Int32
xAligned = Int32 -> Int32 -> Int32 -> Int32 -> Int32
forall {a}. Integral a => a -> a -> a -> a -> a
getAlignedPos Int32
monitorX Int32
xpadding Int32
monitorWidth Int32
width
yAligned :: Int32
yAligned = Int32 -> Int32 -> Int32 -> Int32 -> Int32
forall {a}. Integral a => a -> a -> a -> a -> a
getAlignedPos Int32
monitorY Int32
ypadding Int32
monitorHeight Int32
height
(Int32
xPos, Int32
yPos) =
case StrutPosition
position of
StrutPosition
TopPos -> (Int32
xAligned, Int32
monitorY Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
ypadding)
StrutPosition
BottomPos -> (Int32
xAligned, Int32
monitorY Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
monitorHeight Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
height Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
ypadding)
StrutPosition
LeftPos -> (Int32
monitorX Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
xpadding, Int32
yAligned)
StrutPosition
RightPos -> (Int32
monitorX Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
monitorWidth Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
width Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
xpadding, Int32
yAligned)
Window -> WindowTypeHint -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> WindowTypeHint -> m ()
Gtk.windowSetTypeHint Window
window WindowTypeHint
Gdk.WindowTypeHintDock
Window -> Screen -> m ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsScreen b) =>
a -> b -> m ()
Gtk.windowSetScreen Window
window Screen
screen
Window -> Int32 -> Int32 -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Int32 -> Int32 -> m ()
Gtk.windowMove Window
window Int32
xPos Int32
yPos
Window -> Bool -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Bool -> m ()
Gtk.windowSetKeepBelow Window
window Bool
True
let ewmhSettings :: EWMHStrutSettings
ewmhSettings =
case StrutPosition
position of
StrutPosition
TopPos ->
EWMHStrutSettings
zeroStrutSettings
{ _top :: Int32
_top = Int32
monitorY Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
paddedHeight
, _top_start_x :: Int32
_top_start_x = Int32
xPos Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
xpadding
, _top_end_x :: Int32
_top_end_x = Int32
xPos Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
width Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
xpadding Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1
}
StrutPosition
BottomPos ->
EWMHStrutSettings
zeroStrutSettings
{ _bottom :: Int32
_bottom = Int32
screenHeight Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
monitorY Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
monitorHeight Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
paddedHeight
, _bottom_start_x :: Int32
_bottom_start_x = Int32
xPos Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
xpadding
, _bottom_end_x :: Int32
_bottom_end_x = Int32
xPos Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
width Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
xpadding Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1
}
StrutPosition
LeftPos ->
EWMHStrutSettings
zeroStrutSettings
{ _left :: Int32
_left = Int32
monitorX Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
paddedWidth
, _left_start_y :: Int32
_left_start_y = Int32
yPos Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
ypadding
, _left_end_y :: Int32
_left_end_y = Int32
yPos Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
height Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
ypadding Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1
}
StrutPosition
RightPos ->
EWMHStrutSettings
zeroStrutSettings
{ _right :: Int32
_right = Int32
screenWidth Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
monitorX Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
monitorWidth Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
paddedWidth
, _right_start_y :: Int32
_right_start_y = Int32
yPos Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
ypadding
, _right_end_y :: Int32
_right_end_y = Int32
yPos Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
height Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
ypadding Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1
}
scaledStrutSettings :: EWMHStrutSettings
scaledStrutSettings = Int32 -> EWMHStrutSettings -> EWMHStrutSettings
scaleStrutSettings Int32
monitorScaleFactor EWMHStrutSettings
ewmhSettings
setStrutProperties :: IO ()
setStrutProperties =
IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MaybeT IO () -> IO (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO () -> IO (Maybe ())) -> MaybeT IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
Window
gdkWindow <- IO (Maybe Window) -> MaybeT IO Window
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Window) -> MaybeT IO Window)
-> IO (Maybe Window) -> MaybeT IO Window
forall a b. (a -> b) -> a -> b
$ Window -> IO (Maybe Window)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m (Maybe Window)
Gtk.widgetGetWindow Window
window
IO () -> MaybeT IO ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Window -> EWMHStrutSettings -> IO ()
forall (m :: * -> *) w.
(MonadIO m, IsWindow w) =>
w -> EWMHStrutSettings -> m ()
setStrut Window
gdkWindow EWMHStrutSettings
scaledStrutSettings
logPairs :: [(String, String)]
logPairs =
[ (String
"width", Int32 -> String
forall a. Show a => a -> String
show Int32
width)
, (String
"height", Int32 -> String
forall a. Show a => a -> String
show Int32
height)
, (String
"xPos", Int32 -> String
forall a. Show a => a -> String
show Int32
xPos)
, (String
"yPos", Int32 -> String
forall a. Show a => a -> String
show Int32
yPos)
, (String
"paddedWidth", Int32 -> String
forall a. Show a => a -> String
show Int32
paddedWidth)
, (String
"paddedHeight", Int32 -> String
forall a. Show a => a -> String
show Int32
paddedHeight)
, (String
"monitorWidth", Int32 -> String
forall a. Show a => a -> String
show Int32
monitorWidth)
, (String
"monitorHeight", Int32 -> String
forall a. Show a => a -> String
show Int32
monitorHeight)
, (String
"monitorX", Int32 -> String
forall a. Show a => a -> String
show Int32
monitorX)
, (String
"monitorY", Int32 -> String
forall a. Show a => a -> String
show Int32
monitorY)
, (String
"strutSettings", EWMHStrutSettings -> String
forall a. Show a => a -> String
show EWMHStrutSettings
ewmhSettings)
, (String
"scaledStrutSettings", EWMHStrutSettings -> String
forall a. Show a => a -> String
show EWMHStrutSettings
scaledStrutSettings)
]
Priority -> String -> m ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
strutLog Priority
DEBUG String
"Properties:"
((String, String) -> m ()) -> [(String, String)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(String
name, String
value) -> Priority -> String -> m ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
strutLog Priority
WARNING (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s: %s" String
name String
value) [(String, String)]
logPairs
m SignalHandlerId -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m SignalHandlerId -> m ()) -> m SignalHandlerId -> m ()
forall a b. (a -> b) -> a -> b
$ Window -> ((?self::Window) => IO ()) -> m SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
Gtk.onWidgetRealize Window
window IO ()
(?self::Window) => IO ()
setStrutProperties
allHints :: [Gdk.WindowHints]
allHints :: [WindowHints]
allHints =
[ WindowHints
Gdk.WindowHintsMinSize
, WindowHints
Gdk.WindowHintsMaxSize
, WindowHints
Gdk.WindowHintsBaseSize
, WindowHints
Gdk.WindowHintsUserPos
, WindowHints
Gdk.WindowHintsUserSize
]