Examples of X11 window drawing in haskell

These will be a lot of example how to create windows in haskell, because I plan to write something like dzen, but usable from the xmonad with pure haskell code without the need of creation other processes.

Source of knowledge

https://wiki.haskell.org/X_window_programming_in_Haskell



In [1]:

    
import Data.Bits
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import Control.Concurrent (threadDelay)
 
helloWorld :: IO ()
helloWorld = do
 dpy <- openDisplay ""
 let dflt = defaultScreen dpy
     border = blackPixel dpy dflt
     background = whitePixel dpy dflt
 rootw <- rootWindow dpy dflt
 win <- createSimpleWindow dpy rootw 0 0 100 100 1 border background
 setTextProperty dpy win "Hello World" wM_NAME
 -- make window visible
 mapWindow dpy win
 sync dpy False
 threadDelay (10 * 100000)
 destroyWindow dpy win
 closeDisplay dpy



In [5]:

    
unmanagedWindow = runWindowManageContext $ do
 win <- mkUnmanagedWindow 0 0 100 100
 context <- get
 liftIO $ do
   let dpy = context ^.curDisplay
   setTextProperty dpy win "Hello World" wM_NAME
   mapWindow dpy win
   sync dpy False
   threadDelay (10 * 100000)
   destroyWindow dpy win

 
mkUnmanagedWindow :: Position
                  -> Position
                  -> Dimension
                  -> Dimension
                  -> WindowManage Window
mkUnmanagedWindow x y w h = do
     context <- get
     liftIO $ do
         let scr = context ^. curScreen
             dpy = context ^. curDisplay
             rw = context ^. curRootWindow
             visual = defaultVisualOfScreen scr
             attrmask = cWOverrideRedirect .|. cWBorderPixel .|. cWBackPixel
         win <- allocaSetWindowAttributes $ \attributes -> do
             set_override_redirect attributes True
             set_background_pixel attributes $ whitePixel dpy (defaultScreen dpy)
             set_border_pixel attributes $ blackPixel dpy (defaultScreen dpy)
             createWindow dpy rw x y w h 1 (defaultDepthOfScreen scr) inputOutput visual attrmask attributes
         return win



In [6]:

    
unmanagedWindow



In [2]:

    
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad.Trans.State hiding(get, put)
import Control.Monad.State(MonadState, get, put)
import Control.Monad.IO.Class(MonadIO, liftIO)

newtype WindowManageContext = WindowManageContext (Display, Screen, Window) 
newtype WindowManage a = WindowManage {unWindowManage::StateT WindowManageContext IO a} deriving 
        (Functor, Applicative, Monad, MonadIO, MonadState WindowManageContext)



In [3]:

    
runWindowManageContext :: WindowManage a -> IO a
runWindowManageContext (WindowManage wrappedMonad) = do 
        dpy <- openDisplay ""
        let dflt = defaultScreen dpy
            scr = defaultScreenOfDisplay dpy
        rootw <- rootWindow dpy dflt
        result <- evalStateT wrappedMonad (WindowManageContext (dpy, scr, rootw))
        closeDisplay dpy
        return result



In [4]:

    
import Control.Lens

curDisplay = lens getter setter
  where setter (WindowManageContext tuple) w = WindowManageContext $ tuple & _1 .~ w
        getter (WindowManageContext tuple) = tuple ^. _1

curScreen = lens getter setter
  where setter (WindowManageContext tuple) w = WindowManageContext $ tuple & _2 .~ w
        getter (WindowManageContext tuple) = tuple ^. _2

curRootWindow = lens getter setter
  where setter (WindowManageContext tuple) w = WindowManageContext $ tuple & _3 .~ w
        getter (WindowManageContext tuple) = tuple ^. _3



In [ ]:

    
:t curScreen



In [ ]: