Initial commit

app/WM/XKutu.hs

@@ -0,0 +1,219 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module WM.XKutu where
+
+import Data.Int (Int16, Int32, Int8)
+import Data.Word (Word16, Word32)
+import Foreign (Ptr, Storable, alignment, alloca, peek, peekByteOff, poke, pokeByteOff, sizeOf)
+import Foreign.C.Types (CInt (CInt))
+
+newtype XcbWindow = XcbWindow Word32
+  deriving (Show, Storable)
+
+data Geometry = Geometry
+  { geom_x :: Int16,
+    geom_y :: Int16,
+    geom_w :: Word16,
+    geom_h :: Word16
+  }
+  deriving (Show)
+
+instance Storable Geometry where
+  sizeOf _ = 8
+  alignment _ = alignment (undefined :: Word32)
+
+  peek ptr = do
+    x <- peekByteOff ptr 0
+    y <- peekByteOff ptr 2
+    w <- peekByteOff ptr 4
+    h <- peekByteOff ptr 6
+    pure $ Geometry x y w h
+
+  poke ptr (Geometry x y w h) = do
+    pokeByteOff ptr 0 x
+    pokeByteOff ptr 2 y
+    pokeByteOff ptr 4 w
+    pokeByteOff ptr 6 h
+
+data PointerInfo = PointerInfo
+  { pointer_info_x :: Int16,
+    pointer_info_y :: Int16,
+    pointer_info_w :: XcbWindow
+  }
+  deriving (Show)
+
+instance Storable PointerInfo where
+  sizeOf _ = 8
+  alignment _ = alignment (undefined :: Word32)
+
+  peek ptr = do
+    x <- peekByteOff ptr 0
+    y <- peekByteOff ptr 2
+    w <- peekByteOff ptr 4
+    pure $ PointerInfo x y w
+
+  poke ptr (PointerInfo x y w) = do
+    pokeByteOff ptr 0 x
+    pokeByteOff ptr 2 y
+    pokeByteOff ptr 4 w
+
+data Event = Event
+  { event_type :: Int32,
+    event_window :: XcbWindow,
+    event_override_redirect :: Int8,
+    event_btn :: Word32,
+    event_x :: Int32,
+    event_y :: Int32,
+    event_height :: Word32,
+    event_width :: Word32,
+    event_state :: Word32,
+    event_is_root :: Int8
+  }
+  deriving (Show)
+
+instance Storable Event where
+  sizeOf _ = 40
+  alignment _ = alignment (undefined :: Word32)
+
+  peek ptr = do
+    eventType <- peekByteOff ptr 0
+    window <- peekByteOff ptr 4
+    overrideRedirect <- peekByteOff ptr 8
+    btn <- peekByteOff ptr 12
+    x <- peekByteOff ptr 16
+    y <- peekByteOff ptr 20
+    height <- peekByteOff ptr 24
+    width <- peekByteOff ptr 28
+    state <- peekByteOff ptr 32
+    isRoot <- peekByteOff ptr 36
+
+    pure $
+      Event
+        eventType
+        (XcbWindow window)
+        overrideRedirect
+        btn
+        x
+        y
+        height
+        width
+        state
+        isRoot
+
+  poke ptr (Event eventType (XcbWindow window) overrideRedirect btn x y height width state isRoot) = do
+    pokeByteOff ptr 0 eventType
+    pokeByteOff ptr 4 window
+    pokeByteOff ptr 8 overrideRedirect
+    pokeByteOff ptr 12 btn
+    pokeByteOff ptr 16 x
+    pokeByteOff ptr 20 y
+    pokeByteOff ptr 24 height
+    pokeByteOff ptr 28 width
+    pokeByteOff ptr 32 state
+    pokeByteOff ptr 36 isRoot
+
+foreign import capi "x_kutu.h value MOD"
+  mOD_MASK :: CInt
+
+foreign import capi "x_kutu.h value XCB_MOD_MASK_LOCK"
+  cLK_MASK :: CInt
+
+foreign import capi "x_kutu.h value XCB_MOD_MASK_2"
+  nUM_MASK :: CInt
+
+foreign import capi "x_kutu.h deploy"
+  c_deploy :: IO CInt
+
+deploy :: IO Bool
+deploy = (== 0) <$> c_deploy
+
+foreign import capi "x_kutu.h flush"
+  flush :: IO ()
+
+foreign import capi "x_kutu.h cleanup"
+  cleanup :: IO ()
+
+foreign import capi "x_kutu.h add_keybind"
+  add_keybind :: CInt -> CInt -> IO ()
+
+foreign import capi "x_kutu.h add_mousebind"
+  add_mousebind :: CInt -> CInt -> IO ()
+
+foreign import capi "x_kutu.h get_focus"
+  c_get_focus :: IO Word32
+
+get_focus :: IO XcbWindow
+get_focus = XcbWindow <$> c_get_focus
+
+foreign import capi "x_kutu.h get_root"
+  c_get_root :: IO Word32
+
+get_root :: IO XcbWindow
+get_root = XcbWindow <$> c_get_root
+
+foreign import capi "x_kutu.h focus"
+  focus :: XcbWindow -> IO ()
+
+foreign import capi "x_kutu.h subscribe"
+  subscribe :: XcbWindow -> IO ()
+
+foreign import capi "x_kutu.h kill"
+  kill :: XcbWindow -> IO ()
+
+foreign import capi "x_kutu.h destroy"
+  destroy :: XcbWindow -> IO ()
+
+foreign import capi "x_kutu.h show"
+  show :: XcbWindow -> IO ()
+
+foreign import capi "x_kutu.h hide"
+  hide :: XcbWindow -> IO ()
+
+foreign import capi "x_kutu.h send_to_top"
+  send_to_top :: XcbWindow -> IO ()
+
+foreign import capi "x_kutu.h draw_rectangle"
+  c_draw_rectangle :: CInt -> CInt -> CInt -> CInt -> Word32 -> IO Word32
+
+draw_rectangle :: CInt -> CInt -> CInt -> CInt -> Word32 -> IO XcbWindow
+draw_rectangle x y w h c =
+  XcbWindow <$> c_draw_rectangle x y w h c
+
+foreign import capi "x_kutu.h get_geometry"
+  c_get_geometry :: XcbWindow -> Ptr Geometry -> IO ()
+
+get_geometry :: XcbWindow -> IO Geometry
+get_geometry win =
+  alloca $ \ptr -> do
+    c_get_geometry win ptr
+    peek ptr
+
+foreign import capi "x_kutu.h get_screen"
+  c_get_screen :: Ptr Geometry -> IO ()
+
+get_screen :: IO Geometry
+get_screen =
+  alloca $ \ptr -> do
+    c_get_screen ptr
+    peek ptr
+
+foreign import capi "x_kutu.h get_pointer"
+  c_get_pointer :: Ptr PointerInfo -> IO ()
+
+get_pointer :: IO PointerInfo
+get_pointer =
+  alloca $ \ptr -> do
+    c_get_pointer ptr
+    peek ptr
+
+foreign import capi "x_kutu.h next_event"
+  c_next_event :: Ptr Event -> IO CInt
+
+next_event :: IO (Maybe Event)
+next_event =
+  alloca $ \ptr -> do
+    ok <- c_next_event ptr
+    if ok == 0
+      then pure Nothing
+      else Just <$> peek ptr