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
    }


-- | Build a strut window to the specifications provided by the 'StrutConfig'
-- argument.
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

-- | Configure the provided 'Gtk.Window' so that it has the properties specified
-- by the 'StrutConfig' argument.
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

  -- The screen concept actually encapsulates things displayed across multiple
  -- monitors, which is why we take the maximum here -- what we really want to
  -- know is what is the farthest we can go in each direction on any monitor.
  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 = monitorY + paddedHeight
            , _top_start_x = xPos - xpadding
            , _top_end_x = xPos + width + xpadding - 1
            }
          StrutPosition
BottomPos ->
            EWMHStrutSettings
zeroStrutSettings
            { _bottom = screenHeight - monitorY - monitorHeight + paddedHeight
            , _bottom_start_x = xPos - xpadding
            , _bottom_end_x = xPos + width + xpadding - 1
            }
          StrutPosition
LeftPos ->
            EWMHStrutSettings
zeroStrutSettings
            { _left = monitorX + paddedWidth
            , _left_start_y = yPos - ypadding
            , _left_end_y = yPos + height + ypadding - 1
            }
          StrutPosition
RightPos ->
            EWMHStrutSettings
zeroStrutSettings
            { _right = screenWidth - monitorX - monitorWidth + paddedWidth
            , _right_start_y = yPos - ypadding
            , _right_end_y = yPos + height + ypadding - 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
  ]