Initial commit

app/WM/Core.hs

@@ -0,0 +1,59 @@
+module WM.Core where
+
+import Control.Concurrent (threadDelay)
+import Foreign (Ptr)
+import System.Environment (getArgs)
+import WM.Mruby
+import WM.XKutu
+
+data State = State
+  { mruby_pointer :: Ptr MrbState,
+    running :: Bool
+  }
+  deriving (Show)
+
+run :: IO ()
+run = do
+  is_started <- deploy
+  print is_started
+  add_keybind 24 0
+  w_id <- draw_rectangle 10 100 10 10 0x500070
+  geom <- get_geometry w_id
+  print geom
+  screen_info <- get_screen
+  print screen_info
+  pointer_info <- get_pointer
+  print pointer_info
+  mrb <- mrb_open
+  runRuby mrb runtimeRb
+  handle_args mrb
+  loop $ State mrb True
+  mrb_close mrb
+
+handle_args :: Ptr MrbState -> IO ()
+handle_args mrb = do
+  args <- getArgs
+  case args of
+    [] -> pure ()
+    ["--script", file] -> do
+      script <- readFile file
+      runRuby mrb script
+    _ -> putStrLn "unknown arguments"
+
+handle_event :: Maybe Event -> State -> IO State
+handle_event Nothing state = pure state
+handle_event (Just ev) state
+  | event_btn ev == 24 = pure state {running = False}
+  | otherwise = do
+      print ev
+      pure state
+
+loop :: State -> IO ()
+loop state
+  | not (running state) = pure ()
+  | otherwise = do
+      flush
+      threadDelay 10000
+      ev <- next_event
+      handle_event ev state
+        >>= loop

app/WM/Mruby.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module WM.Mruby where
+
+import Data.FileEmbed (embedFile)
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as TE
+import Data.Text.Encoding.Error qualified as TEE
+import Foreign.C (CString, withCString)
+import Foreign.Ptr
+
+runtimeRb :: String
+runtimeRb =
+  T.unpack (TE.decodeUtf8With TEE.lenientDecode $(embedFile "./app/ruby/lib.rb"))
+
+data MrbState
+
+foreign import capi "mruby.h mrb_open"
+  mrb_open :: IO (Ptr MrbState)
+
+foreign import capi "mruby.h mrb_close"
+  mrb_close :: Ptr MrbState -> IO ()
+
+foreign import capi "mruby/compile.h mrb_load_string"
+  c_mrb_load_string :: Ptr MrbState -> CString -> IO ()
+
+runRuby :: Ptr MrbState -> String -> IO ()
+runRuby mrb code =
+  withCString code $ \cstr ->
+    c_mrb_load_string mrb cstr

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