epq-old/app/WM/XKutu.hs

{-# 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