This is an implementation of tinywm in ada/xcb. You need the ada wrappers for xcb and xproto, not included here because they're too big and still being worked on. I'll put them up on github when I have some time after finishing my minor.

with xcb; use xcb;
with xproto; use xproto;
with Interfaces; use Interfaces;

procedure TinyWM is
   ConnectionFailedException : exception;

   dpy : xcb_connection_t;
   screen : access xcb_screen_t;
   win : xcb_drawable_t;
   root : xcb_drawable_t;

   ev : xcb_generic_event_t_p;

   values : valuearray;
   geom : xcb_get_geometry_reply_t_p;

   error : xcb_generic_error_t;

   vi : Integer;
   pragma Unreferenced (vi);
   vc : xcb_void_cookie_t;
   pragma Unreferenced (vc);
begin

   --  Connect to the X server. Use Null_Display and Null_Screen here so env
   --  variables are used internally
   dpy := xcb_connect (Null_Display, Null_Screen);

   --  Check connection for errors
   if xcb_connection_has_error (dpy) = 1 then
      raise ConnectionFailedException with "Connection failed";
   end if;

   screen := xcb_setup_roots_iterator (xcb_get_setup (dpy)).data;
   root := screen.root;

   vc := xcb_grab_key (dpy, 1, root, XCB_MOD_MASK_2, NO_SYMBOL,
   XCB_GRAB_MODE_ASYNC, XCB_GRAB_MODE_ASYNC);

   vc := xcb_grab_button (dpy, 0, root,
   XCB_EVENT_MASK_BUTTON_PRESS or XCB_EVENT_MASK_BUTTON_RELEASE,
   XCB_GRAB_MODE_ASYNC, XCB_GRAB_MODE_ASYNC, root, XCB_NONE, 1,
   XCB_MOD_MASK_ANY);

   vc := xcb_grab_button (dpy, 0, root,
   XCB_EVENT_MASK_BUTTON_PRESS or XCB_EVENT_MASK_BUTTON_RELEASE,
   XCB_GRAB_MODE_ASYNC, XCB_GRAB_MODE_ASYNC, root, XCB_NONE, 3,
   XCB_MOD_MASK_ANY);

   vi := xcb_flush (dpy);

   Main_Loop :
   loop
      ev := xcb_wait_for_event (dpy);

      case ev.response_type is
         when 4 => -- BUTTON_PRESS
            declare
               e : constant xcb_button_press_event_t_p :=
                  Convert (ev);

                  grab_cookie : xcb_grab_pointer_cookie_t;
            begin
               win := e.child;
               values (0) := Unsigned_32 (XCB_STACK_MODE_ABOVE);
               vc := xcb_configure_window (dpy, win,
               XCB_CONFIG_WINDOW_STACK_MODE,
               values);
               geom := xcb_get_geometry_reply (dpy,
               xcb_get_geometry (dpy, win),
               error);
               if e.detail = 1 then
                  values (2) := 1;
                  vc := xcb_warp_pointer (dpy, XCB_NONE, win,
                  0, 0, 0, 0, 1, 1);
               else
                  values (2) := 3;
                  vc := xcb_warp_pointer (dpy, XCB_NONE, win, 0, 0, 0, 0,
                  geom.width, geom.height);
               end if;
               grab_cookie := xcb_grab_pointer (dpy, 0, root,
               XCB_EVENT_MASK_BUTTON_RELEASE
               or XCB_EVENT_MASK_BUTTON_MOTION
               or XCB_EVENT_MASK_POINTER_MOTION_HINT,
               XCB_GRAB_MODE_ASYNC, XCB_GRAB_MODE_ASYNC,
               root, XCB_NONE, XCB_CURRENT_TIME);
               vi := xcb_flush (dpy);
            end;
         when 5 => -- BUTTON_RELEASE
            vc := xcb_ungrab_pointer (dpy, XCB_CURRENT_TIME);
            vi := xcb_flush (dpy);
         when 6 => -- XCB_MOTION_NOTIFY
            declare
               pointer : xcb_query_pointer_reply_t_p;
            begin
               pointer := xcb_query_pointer_reply (dpy,
               xcb_query_pointer (dpy, root), error);
               if values (2) = 1 then -- left mouse button, move
                  geom := xcb_get_geometry_reply (dpy,
                  xcb_get_geometry (dpy, win),
                  error);

                  if pointer.root_x + Integer_16 (geom.width)
                     > Integer_16 (screen.width_in_pixels)
                  then
                     values (0) :=
                        Unsigned_32 (screen.width_in_pixels - geom.width);
                  else
                     values (0) := Unsigned_32 (pointer.root_x);
                  end if;

                  if pointer.root_y + Integer_16 (geom.height)
                     > Integer_16 (screen.height_in_pixels)
                  then
                     values (1) :=
                        Unsigned_32 (screen.height_in_pixels - geom.height);
                  else
                     values (1) := Unsigned_32 (pointer.root_y);
                  end if;

                  vc := xcb_configure_window (dpy, win,
                  XCB_CONFIG_WINDOW_X or XCB_CONFIG_WINDOW_Y, values);
                  vi := xcb_flush (dpy);
               elsif values (2) = 3 then -- right mouse button, resize
                  geom := xcb_get_geometry_reply (dpy,
                  xcb_get_geometry (dpy, win),
                  error);
                  values (0) :=
                     Unsigned_32 (pointer.root_x - Integer_16 (geom.x));
                     values (1) :=
                        Unsigned_32 (pointer.root_y - Integer_16 (geom.y));
                        vc := xcb_configure_window (dpy, win,
                        XCB_CONFIG_WINDOW_WIDTH or XCB_CONFIG_WINDOW_HEIGHT,
                        values);
                        vi := xcb_flush (dpy);
               end if;
            end;
            vi := xcb_flush (dpy);
         when others =>
            null;
      end case;
   end loop Main_Loop;
end TinyWM;

Comments