xanadu - src/Window.hs

-rw-r--r-- src/Window.hs
      1 {-# LANGUAGE OverloadedLabels #-}
      2 {-# LANGUAGE OverloadedStrings #-}
      3 
      4 module Window (
      5     initWindow
      6 ) where
      7 
      8 import Control.Monad.IO.Class (liftIO)
      9 import Control.Monad.Trans.Maybe
     10 
     11 import Data.GI.Base
     12 import qualified GI.Gdk as Gdk
     13 import qualified GI.Gdk.Enums as Enums
     14 import qualified GI.Gtk as Gtk
     15 import qualified GI.GtkLayerShell as LS
     16 
     17 initWindow :: Gtk.Application -> IO Gtk.ApplicationWindow
     18 initWindow app = do
     19     win <- new Gtk.ApplicationWindow
     20         [ #application := app
     21         , #title := "xanadu"
     22         , #resizable := False
     23         ]
     24 
     25     initWayland win
     26     runMaybeT $ initX11 win
     27     return win
     28 
     29 initWayland :: Gtk.ApplicationWindow -> IO ()
     30 initWayland win = do
     31     LS.initForWindow win
     32     LS.setLayer win LS.LayerBackground
     33     LS.setKeyboardMode win LS.KeyboardModeOnDemand
     34     LS.setAnchor win LS.EdgeTop True
     35     LS.setAnchor win LS.EdgeBottom True
     36     LS.setAnchor win LS.EdgeLeft True
     37     LS.setAnchor win LS.EdgeRight True
     38 
     39 initX11 :: Gtk.ApplicationWindow -> MaybeT IO ()
     40 initX11 win = do
     41     Gtk.windowSetTypeHint win Enums.WindowTypeHintDesktop
     42     display <- MaybeT Gdk.displayGetDefault
     43     monitor <- MaybeT $ Gdk.displayGetMonitor display 0
     44     rect <- liftIO $ Gdk.monitorGetGeometry monitor
     45     width <- Gdk.getRectangleWidth rect
     46     height <- Gdk.getRectangleHeight rect
     47     Gtk.windowSetDefaultSize win width height
     48     Gtk.windowSetKeepBelow win True
     49