268 lines
6.1 KiB
Haskell
268 lines
6.1 KiB
Haskell
{-# 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 :: EventType,
|
|
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)
|
|
|
|
data EventType
|
|
= EvNone
|
|
| EvCreate
|
|
| EvClosed
|
|
| EvEnter
|
|
| EvShowed
|
|
| EvShowRequest
|
|
| EvMousePress
|
|
| EvMouseDrag
|
|
| EvMouseRelease
|
|
| EvKeyPress
|
|
| EvKeyRelease
|
|
| EvClosedTemp
|
|
| EvConfigureRequest
|
|
| EvResizeRequest
|
|
deriving (Show, Eq, Bounded)
|
|
|
|
instance Enum EventType where
|
|
fromEnum ev = case ev of
|
|
EvNone -> 0
|
|
EvCreate -> 1
|
|
EvClosed -> 2
|
|
EvEnter -> 3
|
|
EvShowed -> 4
|
|
EvShowRequest -> 5
|
|
EvMousePress -> 6
|
|
EvMouseDrag -> 7
|
|
EvMouseRelease -> 8
|
|
EvKeyPress -> 9
|
|
EvKeyRelease -> 10
|
|
EvClosedTemp -> 11
|
|
EvConfigureRequest -> 12
|
|
EvResizeRequest -> 13
|
|
toEnum n = case n of
|
|
0 -> EvNone
|
|
1 -> EvCreate
|
|
2 -> EvClosed
|
|
3 -> EvEnter
|
|
4 -> EvShowed
|
|
5 -> EvShowRequest
|
|
6 -> EvMousePress
|
|
7 -> EvMouseDrag
|
|
8 -> EvMouseRelease
|
|
9 -> EvKeyPress
|
|
10 -> EvKeyRelease
|
|
11 -> EvClosedTemp
|
|
12 -> EvConfigureRequest
|
|
13 -> EvResizeRequest
|
|
_ -> error $ "Unknown C EventType number: " ++ show n
|
|
|
|
instance Storable Event where
|
|
sizeOf _ = 40
|
|
alignment _ = alignment (undefined :: Word32)
|
|
peek ptr = do
|
|
rawType <- peekByteOff ptr 0 :: IO Int32
|
|
let eventType = toEnum (fromIntegral rawType)
|
|
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 (fromIntegral (fromEnum eventType) :: Int32)
|
|
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"
|
|
c_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
|