├── .gitmodules ├── src ├── types │ ├── types.h │ ├── types.c │ ├── output.h │ ├── view.h │ ├── keysym.h │ ├── keysym.c │ ├── output.c │ └── view.c ├── hooks │ ├── view_created.h │ ├── output_created.h │ ├── view_destroyed.h │ ├── compositor_ready.h │ ├── output_destroyed.h │ ├── view_render_post.h │ ├── view_render_pre.h │ ├── output_render_pre.h │ ├── output_render_post.h │ ├── compositor_terminate.h │ ├── view_focus.h │ ├── output_focus.h │ ├── keydown.h │ ├── keyup.h │ ├── view_request_geometry.h │ ├── view_move_to_output.h │ ├── output_resolution.h │ ├── pointer_motion.h │ ├── hooks.h │ ├── view_destroyed.c │ ├── compositor_ready.c │ ├── compositor_terminate.c │ ├── output_created.c │ ├── keyup.c │ ├── view_render_pre.c │ ├── view_created.c │ ├── view_render_post.c │ ├── keydown.c │ ├── output_destroyed.c │ ├── output_render_pre.c │ ├── view_focus.c │ ├── output_render_post.c │ ├── output_focus.c │ ├── view_request_geometry.c │ ├── view_move_to_output.c │ ├── output_resolution.c │ ├── pointer_motion.c │ └── hooks.c ├── config.h.in └── gram.c ├── test ├── mocks │ └── gram │ │ ├── output.scm │ │ └── view.scm ├── support │ └── gram │ │ └── support │ │ ├── utils.scm │ │ └── test-setup.scm ├── lib │ ├── render_spec.scm │ └── zipper_spec.scm └── types │ ├── view_spec.c │ └── keysym_spec.c ├── .dir-locals.el ├── .gitignore ├── configure.ac ├── lib_check ├── lib └── gram │ └── lib │ ├── keymap.scm │ ├── motion.scm │ ├── layout.scm │ ├── drag.scm │ ├── render.scm │ ├── render-hooks.scm │ └── zipper.scm ├── README.md ├── LICENSE ├── scripts └── init.scm └── Makefile.am /.gitmodules: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/types/types.h: -------------------------------------------------------------------------------- 1 | #include "keysym.h" 2 | #include "view.h" 3 | #include "output.h" 4 | 5 | void init_gram_types (void); 6 | -------------------------------------------------------------------------------- /src/types/types.c: -------------------------------------------------------------------------------- 1 | #include "types.h" 2 | 3 | void 4 | init_gram_types (void) 5 | { 6 | init_gram_keysym (); 7 | init_gram_view (); 8 | init_gram_output (); 9 | } 10 | -------------------------------------------------------------------------------- /src/hooks/view_created.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | void gram_view_created_hook_init (void); 6 | SCM gram_view_created_hook_run (void *data); 7 | -------------------------------------------------------------------------------- /src/hooks/output_created.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | void gram_output_created_hook_init (void); 6 | SCM gram_output_created_hook_run (void *data); 7 | -------------------------------------------------------------------------------- /src/hooks/view_destroyed.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | void gram_view_destroyed_hook_init (void); 6 | SCM gram_view_destroyed_hook_run (void *data); 7 | -------------------------------------------------------------------------------- /src/hooks/compositor_ready.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | void gram_compositor_ready_hook_init (void); 6 | SCM gram_compositor_ready_hook_run (void *data); 7 | -------------------------------------------------------------------------------- /src/hooks/output_destroyed.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | void gram_output_destroyed_hook_init (void); 6 | SCM gram_output_destroyed_hook_run (void *data); 7 | -------------------------------------------------------------------------------- /src/hooks/view_render_post.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | void gram_view_render_post_hook_init (void); 6 | SCM gram_view_render_post_hook_run (void *data); 7 | -------------------------------------------------------------------------------- /src/hooks/view_render_pre.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | void gram_view_render_pre_hook_init (void); 6 | SCM gram_view_render_pre_hook_run (void *data); 7 | -------------------------------------------------------------------------------- /src/hooks/output_render_pre.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | void gram_output_render_pre_hook_init (void); 6 | SCM gram_output_render_pre_hook_run (void *data); 7 | -------------------------------------------------------------------------------- /src/hooks/output_render_post.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | void gram_output_render_post_hook_init (void); 6 | SCM gram_output_render_post_hook_run (void *data); 7 | -------------------------------------------------------------------------------- /test/mocks/gram/output.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram output) 2 | #:use-module (srfi srfi-9 gnu) 3 | #:export (get-resolution)) 4 | 5 | (define-immutable-record-type output 6 | (make-output) 7 | _output?) 8 | -------------------------------------------------------------------------------- /src/hooks/compositor_terminate.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | void gram_compositor_terminate_hook_init (void); 6 | SCM gram_compositor_terminate_hook_run (void *data); 7 | -------------------------------------------------------------------------------- /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((c-mode 5 | (flycheck-clang-language-standard)) 6 | (scheme-mode 7 | (geiser-scheme-implementation . guile))) 8 | -------------------------------------------------------------------------------- /test/support/gram/support/utils.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram support utils) 2 | #:export (define-dead-mock)) 3 | 4 | (define-syntax-rule (define-dead-mock name) 5 | (define* (name #:rest args) 6 | (error (format "~a called with arguments ~a" name args)))) 7 | -------------------------------------------------------------------------------- /src/hooks/view_focus.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | struct view_focus_input 6 | { 7 | wlc_handle handle; 8 | bool focus; 9 | }; 10 | 11 | void gram_view_focus_hook_init (void); 12 | SCM gram_view_focus_hook_run (void *data); 13 | -------------------------------------------------------------------------------- /src/hooks/output_focus.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | struct output_focus_input 6 | { 7 | wlc_handle handle; 8 | bool focus; 9 | }; 10 | 11 | void gram_output_focus_hook_init (void); 12 | SCM gram_output_focus_hook_run (void *data); 13 | -------------------------------------------------------------------------------- /src/hooks/keydown.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | #include "../types/keysym.h" 5 | 6 | struct keydown_input 7 | { 8 | const wlc_handle view; 9 | struct gram_keysym keysym; 10 | }; 11 | 12 | void gram_keydown_hook_init (void); 13 | SCM gram_keydown_hook_run (void *data); 14 | -------------------------------------------------------------------------------- /src/hooks/keyup.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | #include "../types/keysym.h" 6 | 7 | struct keyup_input 8 | { 9 | const wlc_handle view; 10 | struct gram_keysym keysym; 11 | }; 12 | 13 | void gram_keyup_hook_init (void); 14 | SCM gram_keyup_hook_run (void *data); 15 | -------------------------------------------------------------------------------- /src/hooks/view_request_geometry.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | struct view_geo 6 | { 7 | wlc_handle view; 8 | const struct wlc_geometry *geo; 9 | }; 10 | 11 | void gram_view_request_geometry_hook_init (void); 12 | SCM gram_view_request_geometry_hook_run (void *data); 13 | -------------------------------------------------------------------------------- /src/hooks/view_move_to_output.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | struct move_to_output_input 6 | { 7 | wlc_handle view; 8 | wlc_handle from_out; 9 | wlc_handle to_out; 10 | }; 11 | 12 | void gram_view_move_to_output_hook_init (void); 13 | SCM gram_view_move_to_output_hook_run (void *data); 14 | -------------------------------------------------------------------------------- /src/hooks/output_resolution.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | struct resolution_input 6 | { 7 | wlc_handle handle; 8 | const struct wlc_size *from; 9 | const struct wlc_size *to; 10 | }; 11 | 12 | void gram_output_resolution_hook_init (void); 13 | SCM gram_output_resolution_hook_run (void *data); 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /TAGS 2 | /aclocal.m4 3 | /autom4te.cache 4 | *.log 5 | /config.status 6 | /configure.scan 7 | /gram 8 | .deps 9 | .dirstamp 10 | *.o 11 | /Makefile 12 | *~ 13 | /compile 14 | /configure 15 | /depcomp 16 | /install-sh 17 | /missing 18 | /tap-driver.sh 19 | /test-driver 20 | /Makefile.in 21 | /keysym_check 22 | *.trs 23 | /view_check 24 | /src/config.h 25 | /src/stamp-h1 26 | -------------------------------------------------------------------------------- /test/mocks/gram/view.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram view) 2 | #:use-module (srfi srfi-9 gnu) 3 | #:use-module (gram support utils) 4 | #:export (view? set-output set-geometry)) 5 | 6 | (define-immutable-record-type view 7 | (make-view) 8 | _view?) 9 | 10 | (define (view? v) 11 | (if (equal? v 'test-view) 12 | #t 13 | (error (format "view? called with input ~a" v)))) 14 | 15 | (define-dead-mock set-output) 16 | (define-dead-mock set-geometry) 17 | -------------------------------------------------------------------------------- /src/types/output.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | struct gram_output 6 | { 7 | const wlc_handle output; 8 | bool active; 9 | }; 10 | 11 | scm_t_bits gram_output_tag; 12 | 13 | /* 32 outputs should be enough for everyone, right? RIGHT? */ 14 | #define GRAM_MAX_OUTPUTS 32 15 | 16 | SCM gram_output_scm (const wlc_handle output); 17 | void gram_output_deactivate (const wlc_handle output); 18 | 19 | void init_gram_output (void); 20 | -------------------------------------------------------------------------------- /src/types/view.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | struct gram_view 6 | { 7 | const wlc_handle view; 8 | bool active; 9 | }; 10 | 11 | /* I look forward to the day that someone yells at me for this */ 12 | #define GRAM_MAX_VIEWS 4096 13 | 14 | scm_t_bits gram_view_tag; 15 | 16 | void gram_view_deactivate (const wlc_handle view); 17 | SCM gram_view_scm (const wlc_handle view); 18 | SCM gram_geometry_scm (const struct wlc_geometry *geo); 19 | 20 | void init_gram_view (void); 21 | -------------------------------------------------------------------------------- /src/hooks/pointer_motion.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | 5 | struct pointer_motion_input 6 | { 7 | wlc_handle view; 8 | uint32_t time; 9 | const struct wlc_point *point; 10 | }; 11 | 12 | void gram_pointer_motion_hook_init (void); 13 | SCM gram_pointer_motion_hook_run (void *data); 14 | 15 | /* TODO: move this to its own file. Leaving it here for now because I 16 | * don't want to add all that infrastructure for a single function. */ 17 | void gram_pointer_fns_init (void); 18 | -------------------------------------------------------------------------------- /src/types/keysym.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | #include 3 | #include 4 | #include 5 | 6 | struct gram_keysym 7 | { 8 | struct wlc_modifiers mods; 9 | uint32_t sym; 10 | uint32_t keycode; 11 | bool mouse; 12 | uint32_t mouse_button; 13 | }; 14 | 15 | 16 | extern bool gram_swallow; 17 | scm_t_bits gram_keysym_tag; 18 | 19 | SCM gram_keysym_scm (struct gram_keysym *_keysym); 20 | SCM gram_keysym_construct (SCM key_desc); 21 | SCM gram_key_swallow_next (void); 22 | 23 | void init_gram_keysym (void); 24 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | AC_PREREQ([2.61]) 2 | AC_INIT([gram], [0.1]) 3 | AC_PROG_CC([clang gcc]) 4 | AM_INIT_AUTOMAKE([-Wall -Werror foreign subdir-objects]) 5 | AM_SILENT_RULES([yes]) 6 | 7 | AC_REQUIRE_AUX_FILE([tap-driver.sh]) 8 | 9 | AC_CONFIG_SRCDIR([src/gram.c]) 10 | AC_CONFIG_HEADERS([src/config.h]) 11 | 12 | AC_CHECK_HEADERS([stdlib.h]) 13 | AC_CHECK_HEADERS([unistd.h]) 14 | AC_CHECK_HEADER_STDBOOL 15 | 16 | AC_TYPE_UINT32_T 17 | 18 | PKG_CHECK_MODULES([GUILE], [guile-2.0]) 19 | 20 | PKG_CHECK_MODULES([WLC], [wlc]) 21 | 22 | PKG_CHECK_MODULES([CHECK], [check]) 23 | 24 | AC_CONFIG_FILES([Makefile]) 25 | 26 | AC_OUTPUT 27 | -------------------------------------------------------------------------------- /src/hooks/hooks.h: -------------------------------------------------------------------------------- 1 | #include "keydown.h" 2 | #include "keyup.h" 3 | 4 | #include "view_created.h" 5 | #include "view_destroyed.h" 6 | #include "view_focus.h" 7 | #include "view_move_to_output.h" 8 | #include "view_render_pre.h" 9 | #include "view_render_post.h" 10 | #include "view_request_geometry.h" 11 | 12 | #include "output_created.h" 13 | #include "output_destroyed.h" 14 | #include "output_focus.h" 15 | #include "output_render_pre.h" 16 | #include "output_render_post.h" 17 | #include "output_resolution.h" 18 | 19 | #include "pointer_motion.h" 20 | 21 | #include "compositor_ready.h" 22 | #include "compositor_terminate.h" 23 | 24 | void init_gram_hooks (void); 25 | void* gram_call_hook (scm_t_catch_body hook, void* data); 26 | -------------------------------------------------------------------------------- /src/hooks/view_destroyed.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "view_destroyed.h" 5 | #include "../types/view.h" 6 | 7 | static SCM gram_view_destroyed_hook; 8 | static SCM gram_view_destroyed_hook_object; 9 | 10 | void 11 | gram_view_destroyed_hook_init (void) 12 | { 13 | gram_view_destroyed_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (0))); 15 | gram_view_destroyed_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("view-destroyed-hook", gram_view_destroyed_hook)); 18 | scm_c_export ("view-destroyed-hook", NULL); 19 | } 20 | 21 | SCM 22 | gram_view_destroyed_hook_run (void *data) 23 | { 24 | scm_c_run_hook (gram_view_destroyed_hook, SCM_EOL); 25 | return SCM_UNSPECIFIED; 26 | } 27 | -------------------------------------------------------------------------------- /src/hooks/compositor_ready.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "compositor_ready.h" 5 | 6 | static SCM gram_compositor_ready_hook; 7 | static SCM gram_compositor_ready_hook_object; 8 | 9 | void 10 | gram_compositor_ready_hook_init (void) 11 | { 12 | gram_compositor_ready_hook = 13 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (0))); 14 | gram_compositor_ready_hook_object = 15 | scm_permanent_object (scm_c_define 16 | ("compositor-ready-hook", 17 | gram_compositor_ready_hook)); 18 | scm_c_export ("compositor-ready-hook", NULL); 19 | } 20 | 21 | SCM 22 | gram_compositor_ready_hook_run (void *data) 23 | { 24 | scm_c_run_hook (gram_compositor_ready_hook, SCM_EOL); 25 | return SCM_UNSPECIFIED; 26 | } 27 | -------------------------------------------------------------------------------- /src/hooks/compositor_terminate.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "compositor_terminate.h" 5 | 6 | static SCM gram_compositor_terminate_hook; 7 | static SCM gram_compositor_terminate_hook_object; 8 | 9 | void 10 | gram_compositor_terminate_hook_init (void) 11 | { 12 | gram_compositor_terminate_hook = 13 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (0))); 14 | gram_compositor_terminate_hook_object = 15 | scm_permanent_object (scm_c_define 16 | ("compositor-terminate-hook", 17 | gram_compositor_terminate_hook)); 18 | scm_c_export ("compositor-terminate-hook", NULL); 19 | } 20 | 21 | SCM 22 | gram_compositor_terminate_hook_run (void *data) 23 | { 24 | scm_c_run_hook (gram_compositor_terminate_hook, SCM_EOL); 25 | return SCM_UNSPECIFIED; 26 | } 27 | -------------------------------------------------------------------------------- /src/hooks/output_created.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "output_created.h" 5 | #include "../types/output.h" 6 | 7 | static SCM gram_output_created_hook; 8 | static SCM gram_output_created_hook_object; 9 | 10 | void 11 | gram_output_created_hook_init (void) 12 | { 13 | gram_output_created_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (1))); 15 | gram_output_created_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("output-created-hook", gram_output_created_hook)); 18 | scm_c_export ("output-created-hook", NULL); 19 | } 20 | 21 | SCM 22 | gram_output_created_hook_run (void *data) 23 | { 24 | scm_c_run_hook (gram_output_created_hook, 25 | scm_list_1 (gram_output_scm (*(const wlc_handle *) data))); 26 | return SCM_UNSPECIFIED; 27 | } 28 | -------------------------------------------------------------------------------- /src/hooks/keyup.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "keyup.h" 5 | #include "../types/keysym.h" 6 | #include "../types/view.h" 7 | 8 | static SCM gram_keyup_hook; 9 | static SCM gram_keyup_hook_object; 10 | 11 | void 12 | gram_keyup_hook_init (void) 13 | { 14 | gram_keyup_hook = 15 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (2))); 16 | gram_keyup_hook_object = 17 | scm_permanent_object (scm_c_define ("keyup-hook", gram_keyup_hook)); 18 | scm_c_export ("keyup-hook", NULL); 19 | } 20 | 21 | SCM 22 | gram_keyup_hook_run (void *data) 23 | { 24 | struct keyup_input* input = (struct keyup_input*) data; 25 | scm_c_run_hook (gram_keyup_hook, 26 | scm_list_2 (gram_keysym_scm (&input->keysym), 27 | gram_view_scm(input->view))); 28 | return gram_swallow ? SCM_BOOL_T : SCM_BOOL_F; 29 | } 30 | -------------------------------------------------------------------------------- /lib_check: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env guile 2 | 3 | Test runner for gram. Adapted from Yawar Amin's ggspec runner. 4 | Copyright (c) 2016 J David Smith 5 | 6 | !# 7 | 8 | (add-to-load-path (string-append (dirname (current-filename)) "/" "lib/")) 9 | (add-to-load-path (string-append (dirname (current-filename)) "/test/support/")) 10 | (add-to-load-path (string-append (dirname (current-filename)) "/test/mocks/")) 11 | 12 | (use-modules (gram support test-setup) 13 | (srfi srfi-64) 14 | (ice-9 local-eval) 15 | (ice-9 ftw)) 16 | 17 | (test-runner-current (tap-runner)) 18 | 19 | (test-begin "lib") 20 | 21 | (let ((specs (scandir "test/lib" (lambda (fname) 22 | (string-suffix? "_spec.scm" fname))))) 23 | (map-in-order (lambda (spec) (primitive-load (string-append "test/lib/" spec))) 24 | specs)) 25 | 26 | (test-end "lib") 27 | -------------------------------------------------------------------------------- /src/hooks/view_render_pre.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "view_render_pre.h" 5 | #include "../types/view.h" 6 | 7 | static SCM gram_view_render_pre_hook; 8 | static SCM gram_view_render_pre_hook_object; 9 | 10 | void 11 | gram_view_render_pre_hook_init (void) 12 | { 13 | gram_view_render_pre_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (1))); 15 | gram_view_render_pre_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("view-render-pre-hook", 18 | gram_view_render_pre_hook)); 19 | scm_c_export ("view-render-pre-hook", NULL); 20 | } 21 | 22 | SCM 23 | gram_view_render_pre_hook_run (void *data) 24 | { 25 | scm_c_run_hook (gram_view_render_pre_hook, 26 | scm_list_1 (gram_view_scm (*(const wlc_handle *) data))); 27 | return SCM_UNSPECIFIED; 28 | } 29 | -------------------------------------------------------------------------------- /src/hooks/view_created.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "view_created.h" 5 | #include "../types/view.h" 6 | 7 | static SCM gram_view_created_hook; 8 | static SCM gram_view_created_hook_object; 9 | 10 | void 11 | gram_view_created_hook_init (void) 12 | { 13 | gram_view_created_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (1))); 15 | gram_view_created_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("view-created-hook", gram_view_created_hook)); 18 | scm_c_export ("view-created-hook", NULL); 19 | } 20 | 21 | SCM 22 | gram_view_created_hook_run (void *data) 23 | { 24 | scm_c_run_hook (gram_view_created_hook, 25 | scm_make_list (scm_from_unsigned_integer (1), 26 | gram_view_scm (*(const wlc_handle *) data))); 27 | return SCM_UNSPECIFIED; 28 | } 29 | -------------------------------------------------------------------------------- /src/hooks/view_render_post.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "view_render_post.h" 5 | #include "../types/view.h" 6 | 7 | static SCM gram_view_render_post_hook; 8 | static SCM gram_view_render_post_hook_object; 9 | 10 | void 11 | gram_view_render_post_hook_init (void) 12 | { 13 | gram_view_render_post_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (1))); 15 | gram_view_render_post_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("view-render-post-hook", 18 | gram_view_render_post_hook)); 19 | scm_c_export ("view-render-post-hook", NULL); 20 | } 21 | 22 | SCM 23 | gram_view_render_post_hook_run (void *data) 24 | { 25 | scm_c_run_hook (gram_view_render_post_hook, 26 | scm_list_1 (gram_view_scm (*(const wlc_handle *) data))); 27 | return SCM_UNSPECIFIED; 28 | } 29 | -------------------------------------------------------------------------------- /src/hooks/keydown.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "keydown.h" 5 | #include "../types/keysym.h" 6 | #include "../types/view.h" 7 | 8 | static SCM gram_keydown_hook; 9 | static SCM gram_keydown_hook_object; 10 | 11 | void 12 | gram_keydown_hook_init (void) 13 | { 14 | gram_keydown_hook = 15 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (2))); 16 | gram_keydown_hook_object = 17 | scm_permanent_object (scm_c_define ("keydown-hook", gram_keydown_hook)); 18 | scm_c_export ("keydown-hook", NULL); 19 | } 20 | 21 | SCM 22 | gram_keydown_hook_run (void *data) 23 | { 24 | struct keydown_input* input = (struct keydown_input*) data; 25 | scm_c_run_hook (gram_keydown_hook, 26 | scm_list_2 (gram_keysym_scm (&input->keysym), 27 | gram_view_scm(input->view))); 28 | return gram_swallow ? SCM_BOOL_T : SCM_BOOL_F; 29 | } 30 | -------------------------------------------------------------------------------- /src/hooks/output_destroyed.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "output_destroyed.h" 5 | #include "../types/output.h" 6 | 7 | static SCM gram_output_destroyed_hook; 8 | static SCM gram_output_destroyed_hook_object; 9 | 10 | void 11 | gram_output_destroyed_hook_init (void) 12 | { 13 | gram_output_destroyed_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (1))); 15 | gram_output_destroyed_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("output-destroyed-hook", 18 | gram_output_destroyed_hook)); 19 | scm_c_export ("output-destroyed-hook", NULL); 20 | } 21 | 22 | SCM 23 | gram_output_destroyed_hook_run (void *data) 24 | { 25 | scm_c_run_hook (gram_output_destroyed_hook, 26 | scm_list_1 (gram_output_scm (*(const wlc_handle *) data))); 27 | return SCM_UNSPECIFIED; 28 | } 29 | -------------------------------------------------------------------------------- /src/hooks/output_render_pre.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "output_render_pre.h" 5 | #include "../types/output.h" 6 | 7 | static SCM gram_output_render_pre_hook; 8 | static SCM gram_output_render_pre_hook_object; 9 | 10 | void 11 | gram_output_render_pre_hook_init (void) 12 | { 13 | gram_output_render_pre_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (1))); 15 | gram_output_render_pre_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("output-render-pre-hook", 18 | gram_output_render_pre_hook)); 19 | scm_c_export ("output-render-pre-hook", NULL); 20 | } 21 | 22 | SCM 23 | gram_output_render_pre_hook_run (void *data) 24 | { 25 | 26 | scm_c_run_hook (gram_output_render_pre_hook, 27 | scm_list_1 (gram_output_scm (*(const wlc_handle *) data))); 28 | return SCM_UNSPECIFIED; 29 | } 30 | -------------------------------------------------------------------------------- /src/hooks/view_focus.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "view_focus.h" 5 | #include "../types/view.h" 6 | 7 | static SCM gram_view_focus_hook; 8 | static SCM gram_view_focus_hook_object; 9 | 10 | void 11 | gram_view_focus_hook_init (void) 12 | { 13 | gram_view_focus_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (2))); 15 | gram_view_focus_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("view-focus-hook", gram_view_focus_hook)); 18 | scm_c_export ("view-focus-hook", NULL); 19 | } 20 | 21 | SCM 22 | gram_view_focus_hook_run (void *data) 23 | { 24 | struct view_focus_input *input = (struct view_focus_input *) data; 25 | scm_c_run_hook (gram_view_focus_hook, 26 | scm_list_2 (gram_view_scm (input->handle), 27 | input->focus ? SCM_BOOL_T : SCM_BOOL_F)); 28 | return SCM_UNSPECIFIED; 29 | } 30 | -------------------------------------------------------------------------------- /src/hooks/output_render_post.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "output_render_post.h" 5 | #include "../types/output.h" 6 | 7 | static SCM gram_output_render_post_hook; 8 | static SCM gram_output_render_post_hook_object; 9 | 10 | void 11 | gram_output_render_post_hook_init (void) 12 | { 13 | gram_output_render_post_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (1))); 15 | gram_output_render_post_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("output-render-post-hook", 18 | gram_output_render_post_hook)); 19 | scm_c_export ("output-render-post-hook", NULL); 20 | } 21 | 22 | SCM 23 | gram_output_render_post_hook_run (void *data) 24 | { 25 | 26 | scm_c_run_hook (gram_output_render_post_hook, 27 | scm_list_1 (gram_output_scm (*(const wlc_handle *) data))); 28 | return SCM_UNSPECIFIED; 29 | } 30 | -------------------------------------------------------------------------------- /src/hooks/output_focus.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "output_focus.h" 5 | #include "../types/output.h" 6 | 7 | static SCM gram_output_focus_hook; 8 | static SCM gram_output_focus_hook_object; 9 | 10 | void 11 | gram_output_focus_hook_init (void) 12 | { 13 | gram_output_focus_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (2))); 15 | gram_output_focus_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("output-focus-hook", gram_output_focus_hook)); 18 | scm_c_export ("output-focus-hook", NULL); 19 | } 20 | 21 | SCM 22 | gram_output_focus_hook_run (void *data) 23 | { 24 | struct output_focus_input *input = (struct output_focus_input *) data; 25 | scm_c_run_hook (gram_output_focus_hook, 26 | scm_list_2 (gram_output_scm (input->handle), 27 | input->focus ? SCM_BOOL_T : SCM_BOOL_F)); 28 | return SCM_UNSPECIFIED; 29 | } 30 | -------------------------------------------------------------------------------- /src/hooks/view_request_geometry.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "view_request_geometry.h" 5 | #include "../types/view.h" 6 | 7 | static SCM gram_view_request_geometry_hook; 8 | static SCM gram_view_request_geometry_hook_object; 9 | 10 | void 11 | gram_view_request_geometry_hook_init (void) 12 | { 13 | gram_view_request_geometry_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (2))); 15 | gram_view_request_geometry_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("view-request-geometry-hook", 18 | gram_view_request_geometry_hook)); 19 | scm_c_export ("view-request-geometry-hook", NULL); 20 | } 21 | 22 | SCM 23 | gram_view_request_geometry_hook_run (void *data) 24 | { 25 | struct view_geo *s = (struct view_geo *) data; 26 | scm_c_run_hook (gram_view_request_geometry_hook, 27 | scm_list_2 (gram_view_scm (s->view), 28 | gram_geometry_scm (s->geo))); 29 | return SCM_BOOL_T; 30 | } 31 | -------------------------------------------------------------------------------- /lib/gram/lib/keymap.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram lib keymap) 2 | #:export (default-keymap define-key! clear-key! keymap-hook) 3 | #:use-module (gram keysym) 4 | #:use-module (ice-9 optargs)) 5 | 6 | (define default-keymap '("default" . ())) 7 | 8 | (define* (define-key! km key fn #:optional (swallow? #t)) 9 | "Adds `KEY' as a binding for `FN' to keymap `KM'." 10 | (set-cdr! km (assoc-set! (cdr km) key (cons fn swallow?)))) 11 | 12 | (define (clear-key! km key) 13 | "Removes `KEY' as a binding from keymap `KM'." 14 | (set-cdr! km (assoc-remove! (cdr km) key))) 15 | 16 | (define (keymap-hook km) 17 | (lambda (key view) 18 | (let ((pair (assoc-ref km key))) 19 | (when pair 20 | (let ((fn (car pair)) 21 | (swallow? (cdr pair))) 22 | (let ((arity (car (assoc-ref (procedure-properties fn) 'arity)))) 23 | ;; call either (fn) or (fn view) or (fn key view) based on 24 | ;; procedure arity 25 | (case arity 26 | [(0) (fn)] 27 | [(1) (fn view)] 28 | [(2) (fn key view)])) 29 | (if swallow? 30 | (swallow-next-key))))))) 31 | -------------------------------------------------------------------------------- /src/hooks/view_move_to_output.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "view_move_to_output.h" 5 | #include "../types/view.h" 6 | #include "../types/output.h" 7 | 8 | static SCM gram_view_move_to_output_hook; 9 | static SCM gram_view_move_to_output_hook_object; 10 | 11 | void 12 | gram_view_move_to_output_hook_init (void) 13 | { 14 | gram_view_move_to_output_hook = 15 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (3))); 16 | gram_view_move_to_output_hook_object = 17 | scm_permanent_object (scm_c_define 18 | ("view-move-to-output-hook", 19 | gram_view_move_to_output_hook)); 20 | scm_c_export ("view-move-to-output-hook", NULL); 21 | } 22 | 23 | SCM 24 | gram_view_move_to_output_hook_run (void *data) 25 | { 26 | struct move_to_output_input *input = (struct move_to_output_input *) data; 27 | scm_c_run_hook (gram_view_move_to_output_hook, 28 | scm_list_3 (gram_view_scm (input->view), 29 | gram_output_scm (input->from_out), 30 | gram_output_scm (input->to_out))); 31 | return SCM_UNSPECIFIED; 32 | } 33 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Gram 2 | ==== 3 | 4 | Gram is a highly experimental Wayland window manager. 5 | 6 | *Current Status:* Nearly all basic functionality is present. The major missing piece is completion of the floating layer / mouse support. 7 | 8 | *Completed Functionality*: 9 | 10 | - Workspaces 11 | - Nestable Layouts 12 | - Intra-layout window & cursor motion 13 | - Rudimentary floating layer (appropriate windows (eg `dmenu`) are floated, but there is presently no way to move/resize/focus them if you move focus away from them) 14 | 15 | *To-Be-Done*: 16 | 17 | - Inter-layout cursor motion (issue [#3](../../issues/3), issue [#9](../../issues/9)) 18 | - Complete floating layer / mouse support (issues [#3](../../issues/3), [#4](../../issues/4)) 19 | - Public functions to insert and rearrange nested layouts (issue [#9](../../issues/9)) 20 | 21 | Dependencies 22 | ============ 23 | 24 | [Cloudef/wlc](https://github.com/Cloudef/wlc) 25 | 26 | [libguile](http://www.gnu.org/software/guile/) 27 | 28 | If you're on linux, you almost certainly already have guile installed 29 | as it is an optional dependency of many GNU programs including `gdb`. 30 | 31 | Compiling 32 | ========= 33 | 34 | autoreconf --install 35 | ./configure 36 | make SCHEME_DIR=./lib 37 | -------------------------------------------------------------------------------- /src/hooks/output_resolution.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "output_resolution.h" 5 | #include "../types/output.h" 6 | 7 | static SCM gram_output_resolution_hook; 8 | static SCM gram_output_resolution_hook_object; 9 | 10 | void 11 | gram_output_resolution_hook_init (void) 12 | { 13 | gram_output_resolution_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (3))); 15 | gram_output_resolution_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("output-resolution-hook", 18 | gram_output_resolution_hook)); 19 | scm_c_export ("output-resolution-hook", NULL); 20 | } 21 | 22 | SCM 23 | gram_output_resolution_hook_run (void *data) 24 | { 25 | struct resolution_input *input = (struct resolution_input *) data; 26 | scm_c_run_hook (gram_output_resolution_hook, 27 | scm_list_3 (gram_output_scm (input->handle), 28 | scm_cons (scm_from_uint32 (input->from->w), 29 | scm_from_uint32 (input->from->h)), 30 | scm_cons (scm_from_uint32 (input->to->w), 31 | scm_from_uint32 (input->to->h)))); 32 | return SCM_UNSPECIFIED; 33 | } 34 | -------------------------------------------------------------------------------- /src/hooks/pointer_motion.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "pointer_motion.h" 5 | #include "../types/view.h" 6 | 7 | static SCM gram_pointer_motion_hook; 8 | static SCM gram_pointer_motion_hook_object; 9 | 10 | void 11 | gram_pointer_motion_hook_init (void) 12 | { 13 | gram_pointer_motion_hook = 14 | scm_permanent_object (scm_make_hook (scm_from_unsigned_integer (2))); 15 | gram_pointer_motion_hook_object = 16 | scm_permanent_object (scm_c_define 17 | ("pointer-motion-hook", gram_pointer_motion_hook)); 18 | scm_c_export ("pointer-motion-hook", NULL); 19 | } 20 | 21 | SCM 22 | gram_pointer_motion_hook_run (void *data) 23 | { 24 | struct pointer_motion_input *input = (struct pointer_motion_input *) data; 25 | scm_c_run_hook (gram_pointer_motion_hook, 26 | scm_list_2 (gram_view_scm (input->view), 27 | scm_cons (scm_from_uint32 (input->point->x), 28 | scm_from_uint32 (input->point->y)))); 29 | return SCM_UNSPECIFIED; 30 | } 31 | 32 | SCM 33 | gram_pointer_position (void) 34 | { 35 | struct wlc_point pos; 36 | wlc_pointer_get_position(&pos); 37 | 38 | return scm_cons(scm_from_uint32(pos.x), 39 | scm_from_uint32(pos.y)); 40 | } 41 | 42 | void gram_pointer_fns_init (void) 43 | { 44 | scm_c_define_gsubr("pointer-position", 0, 0, 0, gram_pointer_position); 45 | 46 | scm_c_export("pointer-position", NULL); 47 | } 48 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2016, J David Smith 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /scripts/init.scm: -------------------------------------------------------------------------------- 1 | (use-modules (ice-9 popen) 2 | (srfi srfi-26) 3 | (system repl server) 4 | ((gram view) 5 | #:renamer (symbol-prefix-proc 'view-)) 6 | (gram view hooks) 7 | (gram keysym) 8 | (gram keysym hooks) 9 | ((gram output) 10 | #:renamer (symbol-prefix-proc 'output-)) 11 | (gram lib zipper) 12 | (gram lib motion) 13 | (gram lib render-hooks) 14 | (gram lib keymap) 15 | (gram lib drag)) 16 | 17 | (spawn-server) 18 | 19 | (display "Test from guile!\n") 20 | 21 | ;; (add-hook! view-created-hook (lambda (v) (display (output-get-views (view-get-output v))))) 22 | ;; (add-hook! view-created-hook (lambda (v) (display v))) 23 | 24 | (define (run cmd) 25 | "Alias for `open-input-output-pipe'." 26 | (open-input-output-pipe cmd)) 27 | 28 | 29 | (add-hook! keydown-hook (keymap-hook default-keymap)) 30 | 31 | (define-key! default-keymap (kbd "M-x") (cute run "dmenu_run")) 32 | (define-key! default-keymap (kbd "M-") (cute run "st")) 33 | (define-key! default-keymap (kbd "M-b") (cute run "evince")) 34 | (define-key! default-keymap (kbd "M-n") (cute move-cursor 'right)) 35 | (define-key! default-keymap (kbd "M-e") (cute move-cursor 'left)) 36 | (define-key! default-keymap (kbd "C-M-n") (cute move-window 'right)) 37 | (define-key! default-keymap (kbd "C-M-e") (cute move-window 'left)) 38 | (define-key! default-keymap (kbd "Mouse1") window-focus) 39 | 40 | (define-key! default-keymap (kbd "M-.") (cute focus-layer 'floating)) 41 | (define-key! default-keymap (kbd "M-,") (cute focus-layer 'tiling)) 42 | 43 | (drag-setup default-keymap drag-move-view (kbd "M-Mouse1")) 44 | (drag-setup default-keymap drag-resize-view (kbd "M-Mouse2")) 45 | -------------------------------------------------------------------------------- /test/support/gram/support/test-setup.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram support test-setup) 2 | #:use-module (srfi srfi-64) 3 | #:export (tap-runner describe it)) 4 | 5 | (define (tap-test-end runner) 6 | (let ((name (string-join (cdr (test-runner-group-path runner)) " ")) 7 | (desc (test-runner-test-name runner))) 8 | (case (test-result-kind runner) 9 | ((pass xfail) (format #t "ok ~a ~a~%" name desc)) 10 | ((fail xpass) (format #t "not ok ~a ~a~%" name desc)) 11 | ((skip) (format #t "ok ~a ~a # SKIP~%" name desc))))) 12 | 13 | (define (tap-group-begin runner name count) 14 | (format #t "# Describe ~a~%" name) 15 | (test-runner-aux-value! runner (+ (test-runner-aux-value runner) 16 | (or count 0)))) 17 | 18 | (define (tap-test-final runner) 19 | (format #t "1..~a~%" (test-runner-aux-value runner))) 20 | 21 | (define (tap-bad-count runner actual expected) 22 | (format #t "Bail out! Expected ~a tests in ~a. Ran ~a.~%" 23 | expected 24 | (car (test-runner-group-stack runner)) 25 | actual) 26 | (exit -1)) 27 | 28 | (define (tap-runner) 29 | (let ((runner (test-runner-null))) 30 | (test-runner-on-test-end! runner tap-test-end) 31 | (test-runner-on-group-begin! runner tap-group-begin) 32 | (test-runner-on-bad-count! runner tap-bad-count) 33 | (test-runner-on-final! runner tap-test-final) 34 | (test-runner-aux-value! runner 0) 35 | runner)) 36 | 37 | (define-macro (describe name . tests) 38 | `(begin 39 | ,(let ((test-count (length (filter (lambda (test) (eq? (car test) 'it)) tests)))) 40 | (if (= test-count 0) 41 | `(test-begin ,name) 42 | `(test-begin ,name ,test-count))) 43 | ,@tests 44 | (test-end ,name))) 45 | 46 | (define-macro (it should . body) 47 | `(begin 48 | (test-assert ,should (begin ,@body)))) 49 | -------------------------------------------------------------------------------- /test/lib/render_spec.scm: -------------------------------------------------------------------------------- 1 | (use-modules (gram lib render) 2 | (gram support test-setup)) 3 | 4 | ;;; testing these two even though they are private because the 5 | ;;; behavior is slightly more complex. 6 | ;;; 7 | ;;; they may be moved to a different location and made public in the 8 | ;;; future if I find use for them in different modules. 9 | 10 | (describe "(gram lib render)" 11 | (define remove-keys (@@ (gram lib render) remove-keys)) 12 | 13 | (describe "remove-keys" 14 | (it "should remove all keywords from the input" 15 | (not (> 0 (length (remove-keys '(#:a #:b)))))) 16 | (it "should remove all key/value pairs from the input" 17 | (not (> 0 (length (remove-keys '(#:a 1 #:b 2)))))) 18 | (it "should not remove any value that is not a keyword and not paired with a keyword" 19 | (equal? '(2 3 4 5) (remove-keys '(#:a 1 2 3 #:b 2 4 5 #:c))))) 20 | 21 | (define flatten-once (@@ (gram lib render) flatten-once)) 22 | 23 | (describe "flatten-once" 24 | (it "should flatten a list by exactly one level" 25 | (equal? '(a (b (c d)) e f g) (flatten-once '(a ((b (c d)) e f) g)))))) 26 | 27 | ;; (define (assert-map-all ls assertion) 28 | ;; (apply assert-all (map assertion ls))) 29 | 30 | ;; (suite "make-renderable" 31 | ;; (it "should return an rview given a view" 32 | ;; (let ((rv (make-renderable 'test-view 'out 33 | ;; '(0 . 0) '(100 . 100)))) 34 | ;; (assert-all 35 | ;; (assert-true (rview? rv)) 36 | ;; (equal? (rview-view rv) 'test-view) 37 | ;; (equal? (rview-output rv) 'out)))) 38 | ;; (it "should return a list of rviews given a layout procedure" 39 | ;; (let ((rvs (make-renderable (lambda (dims out) 40 | ;; (list 41 | ;; (make-rview 'a out '(0 . 0) '(100 . 100)) 42 | ;; (make-rview 'b out '(100 . 0) '(100 . 100)))) 43 | ;; 'out '(10 . 10) '(100 . 100)))) 44 | ;; (assert-map-all rvs rview?)))) 45 | -------------------------------------------------------------------------------- /src/config.h.in: -------------------------------------------------------------------------------- 1 | /* src/config.h.in. Generated from configure.ac by autoheader. */ 2 | 3 | /* Define to 1 if you have the header file. */ 4 | #undef HAVE_INTTYPES_H 5 | 6 | /* Define to 1 if you have the header file. */ 7 | #undef HAVE_MEMORY_H 8 | 9 | /* Define to 1 if you have the header file. */ 10 | #undef HAVE_STDINT_H 11 | 12 | /* Define to 1 if you have the header file. */ 13 | #undef HAVE_STDLIB_H 14 | 15 | /* Define to 1 if you have the header file. */ 16 | #undef HAVE_STRINGS_H 17 | 18 | /* Define to 1 if you have the header file. */ 19 | #undef HAVE_STRING_H 20 | 21 | /* Define to 1 if you have the header file. */ 22 | #undef HAVE_SYS_STAT_H 23 | 24 | /* Define to 1 if you have the header file. */ 25 | #undef HAVE_SYS_TYPES_H 26 | 27 | /* Define to 1 if you have the header file. */ 28 | #undef HAVE_UNISTD_H 29 | 30 | /* Define to 1 if the system has the type `_Bool'. */ 31 | #undef HAVE__BOOL 32 | 33 | /* Name of package */ 34 | #undef PACKAGE 35 | 36 | /* Define to the address where bug reports for this package should be sent. */ 37 | #undef PACKAGE_BUGREPORT 38 | 39 | /* Define to the full name of this package. */ 40 | #undef PACKAGE_NAME 41 | 42 | /* Define to the full name and version of this package. */ 43 | #undef PACKAGE_STRING 44 | 45 | /* Define to the one symbol short name of this package. */ 46 | #undef PACKAGE_TARNAME 47 | 48 | /* Define to the home page for this package. */ 49 | #undef PACKAGE_URL 50 | 51 | /* Define to the version of this package. */ 52 | #undef PACKAGE_VERSION 53 | 54 | /* Define to 1 if you have the ANSI C header files. */ 55 | #undef STDC_HEADERS 56 | 57 | /* Version number of package */ 58 | #undef VERSION 59 | 60 | /* Define for Solaris 2.5.1 so the uint32_t typedef from , 61 | , or is not used. If the typedef were allowed, the 62 | #define below would cause a syntax error. */ 63 | #undef _UINT32_T 64 | 65 | /* Define to the type of an unsigned integer type of width exactly 32 bits if 66 | such a type exists and the standard includes do not define it. */ 67 | #undef uint32_t 68 | -------------------------------------------------------------------------------- /lib/gram/lib/motion.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram lib motion) 2 | #:use-module (gram lib zipper) 3 | #:use-module ((gram lib render-hooks) #:select (transform-layout! current-view %current-workspace set-focused-layout! containing-layer focus-layer)) 4 | #:use-module ((gram view) #:renamer (symbol-prefix-proc 'view-)) 5 | #:export (move-cursor move-window window-focus)) 6 | 7 | (define (function s) 8 | (eval s (current-module))) 9 | 10 | (define (move-cursor dir) 11 | "Move the focus cursor in the specified direction in the current 12 | layer." 13 | (transform-layout! (lambda (z) 14 | (z-> z (go dir)))) 15 | (let ((v (current-view))) 16 | (when v 17 | (view-focus v)))) 18 | 19 | (define (move-window dir) 20 | "Move the window and cursor in the specified direction in the 21 | current layer." 22 | (transform-layout! (lambda (z) 23 | (z-> z (rotate dir) (go dir))))) 24 | 25 | (define (move-cursor-to-layout layout) 26 | "Move the focus cursor to the specified layout." 27 | (if (member layout '(tiling floating)) 28 | (begin 29 | (set-focused-layout! %current-workspace layout) 30 | (let ((v (current-view))) 31 | (when v 32 | (view-focus v)))) 33 | (error "~a is not a valid layout (try 'tiling or 'floating)" layout))) 34 | 35 | (define (move-window-to-layout layout) 36 | "Move the current window to the specified layout and focus it." 37 | (if (member layout '(tiling floating)) 38 | (begin 39 | (let ((v (current-view))) 40 | (transform-layout! (lambda (z) 41 | (z-> z (del)))) 42 | (set-focused-layout! %current-workspace layout) 43 | (transform-layout! (lambda (z) 44 | (z-> z (insert v 'right)))) 45 | (move-cursor 'right))))) 46 | 47 | (define (window-focus view) 48 | "Change the current focus to `view'. This function should be 49 | preferred to `view-focus' because it maintains the cursor state 50 | correctly." 51 | (let ([layer (containing-layer view)]) 52 | (focus-layer layer) 53 | (transform-layout! (lambda (z) 54 | (find z (lambda (x) 55 | (equal? x view))))) 56 | (view-focus (current-view)))) 57 | -------------------------------------------------------------------------------- /Makefile.am: -------------------------------------------------------------------------------- 1 | SCHEME_DIR ?= "$(pkgdatadir)/site-scheme" 2 | AM_CFLAGS=@GUILE_CFLAGS@ @WLC_CFLAGS@ -Wall -g -DSCHEME_DIR="\"$(SCHEME_DIR)\"" 3 | AM_LDFLAGS=@GUILE_LIBS@ @WLC_LIBS@ 4 | bin_PROGRAMS = gram 5 | gram_SOURCES = src/gram.c src/types/keysym.c src/types/view.c \ 6 | src/types/output.c src/types/types.c src/hooks/hooks.c \ 7 | src/hooks/keydown.c src/hooks/keyup.c src/hooks/view_created.c \ 8 | src/hooks/compositor_ready.c src/hooks/compositor_terminate.c \ 9 | src/hooks/output_created.c src/hooks/output_destroyed.c \ 10 | src/hooks/output_focus.c src/hooks/output_render_post.c \ 11 | src/hooks/output_render_pre.c src/hooks/output_resolution.c \ 12 | src/hooks/pointer_motion.c src/hooks/view_destroyed.c \ 13 | src/hooks/view_focus.c src/hooks/view_move_to_output.c \ 14 | src/hooks/view_render_post.c src/hooks/view_render_pre.c \ 15 | src/hooks/view_request_geometry.c 16 | gram_SOURCES_H = src/types/keysym.h src/types/view.h \ 17 | src/types/output.h src/types/types.h src/hooks/hooks.h \ 18 | src/hooks/view_created.h src/hooks/keydown.h \ 19 | src/hooks/compositor_ready.h src/hooks/compositor_terminate.h \ 20 | src/hooks/output_created.h src/hooks/output_destroyed.h \ 21 | src/hooks/output_focus.h src/hooks/output_render_post.h \ 22 | src/hooks/output_render_pre.h src/hooks/output_resolution.h \ 23 | src/hooks/pointer_motion.h src/hooks/view_destroyed.h \ 24 | src/hooks/view_focus.h src/hooks/view_move_to_output.h \ 25 | src/hooks/view_render_post.h src/hooks/view_render_pre.h \ 26 | src/hooks/view_request_geometry.h 27 | 28 | dist_pkgdata_DATA = lib/gram/lib/layout.scm lib/gram/lib/render.scm lib/gram/lib/zipper.scm 29 | 30 | TESTS = keysym_check view_check lib_check 31 | check_PROGRAMS = keysym_check view_check 32 | keysym_check_SOURCES = src/types/keysym.c test/types/keysym_spec.c 33 | keysym_check_CFLAGS=$(AM_CFLAGS) @CHECK_CFLAGS@ 34 | keysym_check_LDADD=@CHECK_LIBS@ 35 | 36 | view_check_SOURCES = src/types/view.c src/types/output.c test/types/view_spec.c 37 | view_check_CFLAGS=$(AM_CFLAGS) @CHECK_CFLAGS@ 38 | view_check_LDADD=@CHECK_LIBS@ 39 | 40 | TESTS_SRCS = $(keysym_check_SOURCES) $(view_check_SOURCES) 41 | 42 | LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ 43 | $(top_srcdir)/tap-driver.sh 44 | 45 | indent: $(gram_SOURCES) $(gram_SOURCES_H) $(TESTS_SRCS) 46 | indent -bli0 --no-tabs $^ 47 | 48 | test: check 49 | -------------------------------------------------------------------------------- /lib/gram/lib/layout.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram lib layout) 2 | #:use-module (srfi srfi-9 gnu) 3 | #:use-module (srfi srfi-26) 4 | #:use-module (ice-9 match) 5 | #:use-module (gram lib render) 6 | #:use-module ((gram view) 7 | #:renamer (symbol-prefix-proc 'view-)) 8 | #:export (columns rows tall simple)) 9 | 10 | (define-layout columns ((weights #nil)) 11 | "Lay out windows in columns, with the weights option specifying 12 | their relative sizes." 13 | (lambda (views opts output dims) 14 | (match dims 15 | ((width . height) 16 | (let ((view-width (floor/ width (length views)))) 17 | (map 18 | (lambda (v i) 19 | (if (= i (- (length views) 1)) 20 | (place v output 21 | (cons (* i view-width) 0) 22 | (cons (- width (* i view-width)) height)) 23 | (place v output 24 | (cons (* i view-width) 0) 25 | (cons view-width height)))) 26 | views (iota (length views)))))))) 27 | 28 | (define (cons-rev c) 29 | (cons (cdr c) (car c))) 30 | 31 | (define-layout rows ((weights #nil)) 32 | "Lay out windows in rows, with relative sizes specified by the 33 | weights option." 34 | (lambda (views opts output dims) 35 | (map (lambda (rv) 36 | (let ((irv (rview-set-origin rv (cons-rev (rview-origin rv))))) 37 | (rview-set-dimensions irv (cons-rev (rview-dimensions rv))))) 38 | (layout-with columns views opts output (cons-rev dims))))) 39 | 40 | (define-layout tall ((weights #nil) (main #nil)) 41 | "Lay out one window (the master) full height, and the remaining in 42 | rows next to it." 43 | (lambda (views opts output dims) 44 | (let* ((main (or (assoc-ref opts 'main) (car views))) 45 | (rest (delq main views))) 46 | (layout-with columns (if (null? rest) 47 | (list main) 48 | (list main (apply rows #:weights (assoc-ref opts 'weights) rest))) 49 | '() output dims)))) 50 | 51 | (define-layout simple () 52 | "Lay out windows exactly where they ask to be. If they don't ask to 53 | be anywhere, place them in the upper-left corner." 54 | (lambda (views opts output dims) 55 | (map (lambda (v) 56 | (match (view-get-geometry v) 57 | ((origin . dimensions) 58 | (place v output origin dimensions)))) 59 | views))) 60 | -------------------------------------------------------------------------------- /src/hooks/hooks.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include "hooks.h" 4 | 5 | static void 6 | init_gram_key_hooks (void *ignore) 7 | { 8 | gram_keydown_hook_init (); 9 | gram_keyup_hook_init (); 10 | } 11 | 12 | static void 13 | init_gram_view_hooks (void *ignore) 14 | { 15 | gram_view_created_hook_init (); 16 | gram_view_destroyed_hook_init (); 17 | gram_view_focus_hook_init (); 18 | gram_view_move_to_output_hook_init (); 19 | gram_view_render_pre_hook_init (); 20 | gram_view_render_post_hook_init (); 21 | gram_view_request_geometry_hook_init (); 22 | } 23 | 24 | static void 25 | init_gram_output_hooks (void *ignore) 26 | { 27 | gram_output_created_hook_init (); 28 | gram_output_destroyed_hook_init (); 29 | gram_output_focus_hook_init (); 30 | gram_output_render_pre_hook_init (); 31 | gram_output_render_post_hook_init (); 32 | gram_output_resolution_hook_init (); 33 | } 34 | 35 | static void 36 | init_gram_pointer_hooks (void *ignore) 37 | { 38 | gram_pointer_motion_hook_init (); 39 | } 40 | 41 | static void 42 | init_gram_pointer (void *ignore) 43 | { 44 | /* defined in pointer_motion.h */ 45 | gram_pointer_fns_init(); 46 | } 47 | 48 | static void 49 | init_gram_compositor_hooks (void *ignore) 50 | { 51 | gram_compositor_ready_hook_init (); 52 | gram_compositor_terminate_hook_init (); 53 | } 54 | 55 | void 56 | init_gram_hooks (void) 57 | { 58 | scm_c_define_module ("gram keysym hooks", init_gram_key_hooks, NULL); 59 | scm_c_define_module ("gram view hooks", init_gram_view_hooks, NULL); 60 | scm_c_define_module ("gram output hooks", init_gram_output_hooks, NULL); 61 | scm_c_define_module ("gram pointer hooks", init_gram_pointer_hooks, NULL); 62 | scm_c_define_module ("gram compositor hooks", init_gram_compositor_hooks, 63 | NULL); 64 | /* this is out of place but I don't have a better spot for it right 65 | * now. */ 66 | 67 | scm_c_define_module ("gram pointer", init_gram_pointer, NULL); 68 | } 69 | 70 | struct gram_hook_wrapper { 71 | SCM (*hook)(void*); 72 | void* data; 73 | }; 74 | 75 | static SCM 76 | gram_hook_error_handler(void* data, SCM key, SCM args) { 77 | return scm_simple_format(SCM_BOOL_T, scm_from_locale_string("~A error thrown with arguments ~A\n"), scm_list_2(key, args)); 78 | } 79 | 80 | static void* 81 | gram_call_hook_body(void* data) { 82 | struct gram_hook_wrapper hook = * (struct gram_hook_wrapper*) data; 83 | return (void*)scm_internal_catch(SCM_BOOL_T, hook.hook, hook.data, 84 | gram_hook_error_handler, NULL); 85 | } 86 | 87 | void* 88 | gram_call_hook(scm_t_catch_body hook, void* data) { 89 | struct gram_hook_wrapper wrapper = { 90 | .hook = hook, 91 | .data = data 92 | }; 93 | return scm_with_guile(gram_call_hook_body, &wrapper); 94 | } 95 | -------------------------------------------------------------------------------- /lib/gram/lib/drag.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram lib drag) 2 | #:export (drag-move-view drag-resize-view drag-stop-acting drag-setup) 3 | #:use-module (srfi srfi-11) 4 | #:use-module (ice-9 match) 5 | #:use-module (gram pointer) 6 | #:use-module (gram pointer hooks) 7 | #:use-module (gram keysym hooks) 8 | #:use-module (gram keysym) 9 | #:use-module (gram lib keymap) 10 | #:use-module (gram lib render-hooks) 11 | #:use-module (gram lib zipper) 12 | #:use-module ((gram view) #:renamer (symbol-prefix-proc 'view-))) 13 | 14 | ;;; starting position for a drag. Can't drag multiple at once, but I 15 | ;;; can't imagine how you would manage that. 16 | (define %origin #f) 17 | ;;; original geometry 18 | (define %origin-geometry #f) 19 | ;;; action taking place, either do-move or do-resize 20 | (define %action #f) 21 | ;;; view being acted on 22 | (define %action-target #f) 23 | 24 | (define (acting?) 25 | "Returns #t if the user is currently acting on (moving or resizing) 26 | a view." 27 | (and %origin %origin-geometry %action %action-target)) 28 | 29 | (define (drag-stop-acting) 30 | "Stops the interaction. Only one interaction can occur at a time." 31 | (set! %origin #f) 32 | (set! %origin-geometry #f) 33 | (set! %action #f) 34 | (set! %action-target #f)) 35 | 36 | (define (distance-moved origin position) 37 | (values 38 | (- (car position) (car origin)) 39 | (- (cdr position) (cdr origin)))) 40 | 41 | (define (on-move _ position) 42 | (when (acting?) 43 | (%action position))) 44 | 45 | (define (do-move! position) 46 | (when (acting?) 47 | (let-values ([(dx dy) (distance-moved %origin position)]) 48 | (match %origin-geometry 49 | [((x . y) . dims) 50 | (view-set-geometry %action-target (cons 51 | (cons (+ x dx) (+ y dy)) 52 | dims))] 53 | [_ (error "Invalid origin geometry ~a" %origin-geometry)])))) 54 | 55 | (define (do-resize! position) 56 | (when (acting?) 57 | (let-values ([(dx dy) (distance-moved %origin position)]) 58 | (match %origin-geometry 59 | [(pos w . h) 60 | (view-set-geometry %action-target (cons 61 | pos 62 | (cons (+ w dx) (+ h dy))))] 63 | [_ (error "Invalid origin geometry ~a" %origin-geometry)])))) 64 | 65 | (define-syntax-rule (define-interaction name act docstring) 66 | (define (name view) 67 | docstring 68 | (unless (acting?) 69 | (let ((eq (lambda (x) (equal? view x)))) 70 | (transform-workspace! 'tiling (lambda (z) 71 | (transform z eq del))) 72 | (transform-workspace! 'floating (lambda (z) 73 | (if (find z eq) 74 | z 75 | (or (add-view z view) z))))) 76 | (focus-layer 'floating) 77 | (view-bring-to-front view) 78 | (re-render!) 79 | (set! %origin (pointer-position)) 80 | (set! %origin-geometry (view-get-geometry view)) 81 | (set! %action act) 82 | (set! %action-target view)))) 83 | 84 | (define-interaction drag-move-view do-move! 85 | "Begin moving the given view with the given position as the origin.") 86 | (define-interaction drag-resize-view do-resize! 87 | "Begin resizing the given view with the given position as the origin.") 88 | 89 | (define (drag-setup km interaction key) 90 | "Set up the given interaction to begin when `key' is pressed and end 91 | when the unmodified `key' is released." 92 | (define-key! km key interaction) 93 | (add-hook! keyup-hook (lambda (released view) 94 | (let ((rel (unmodified released))) 95 | (when (equal? rel (unmodified key)) 96 | (drag-stop-acting))))) 97 | (unless (member on-move (hook->list pointer-motion-hook)) 98 | (add-hook! pointer-motion-hook on-move))) 99 | -------------------------------------------------------------------------------- /lib/gram/lib/render.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram lib render) 2 | #:use-module (srfi srfi-9 gnu) 3 | #:use-module (srfi srfi-26) 4 | #:use-module (oop goops) 5 | #:use-module (ice-9 match) 6 | #:use-module (gram lib zipper) 7 | #:use-module ((gram view) 8 | #:renamer (symbol-prefix-proc 'view-)) 9 | #:use-module ((gram output) 10 | #:renamer (symbol-prefix-proc 'output-)) 11 | #:export (define-layout place render-post-hook render! 12 | layout? layout-with 13 | rview? 14 | rview-view rview-set-view 15 | rview-origin rview-set-origin 16 | rview-output rview-set-output 17 | rview-dimensions rview-set-dimensions)) 18 | 19 | (define-generic place) 20 | 21 | (define-immutable-record-type rview 22 | (make-rview view output origin dimensions) 23 | rview? 24 | (view rview-view rview-set-view) 25 | (output rview-output rview-set-output) 26 | (origin rview-origin rview-set-origin) 27 | (dimensions rview-dimensions rview-set-dimensions)) 28 | 29 | (define-method (place (view ) (output ) (origin ) (dims )) 30 | (make-rview view output origin dims)) 31 | 32 | (define-immutable-record-type layout 33 | (make-layout type render views opts) 34 | layout? 35 | (type layout-type layout-set-type) 36 | (render layout-render-fn layout-set-render-fn) 37 | (views layout-views layout-set-views) 38 | (opts layout-opts layout-set-opts)) 39 | 40 | (set-record-type-printer! 41 | layout 42 | (lambda (rec port) 43 | (match rec 44 | (($ layout type _ views opts) 45 | (format port "(~s~{ ~s~}~{ ~s~})" type (alist->kvs opts) views)) 46 | (_ (error "Unable to display record" rec))))) 47 | 48 | (define-method (children (lout )) 49 | (layout-views lout)) 50 | 51 | (define-method (extract (views ) (old-layout )) 52 | (layout-set-views old-layout views)) 53 | 54 | (define (remove-keys ls) 55 | "Remove all keys and key-value pairs from list `ls'." 56 | (let ((key-indices (filter (lambda (v) (not (unspecified? v))) 57 | (map-in-order (lambda (v i) (when (keyword? v) i)) 58 | ls (iota (length ls)))))) 59 | (filter 60 | (lambda (v) (not (unspecified? v))) 61 | (map-in-order (lambda (v i) 62 | (unless (or (member i key-indices) 63 | (member (- i 1) key-indices)) v)) 64 | ls (iota (length ls)))))) 65 | 66 | (define (only-keys ls) 67 | "Remove all keys and key-value pairs from list `ls'." 68 | (let ((key-indices (filter (lambda (v) (not (unspecified? v))) 69 | (map-in-order (lambda (v i) 70 | (when (keyword? v) i)) 71 | ls (iota (length ls)))))) 72 | (filter 73 | (lambda (v) (not (unspecified? v))) 74 | (map-in-order (lambda (v i) 75 | (when (or (member i key-indices) 76 | (member (- i 1) key-indices)) 77 | v)) 78 | ls (iota (length ls)))))) 79 | 80 | (define (kvs->alist kvs) 81 | (if (null? kvs) 82 | kvs 83 | (acons (keyword->symbol (car kvs)) 84 | (cadr kvs) 85 | (kvs->alist (cddr kvs))))) 86 | 87 | (define (alist->kvs alist) 88 | (if (null? alist) 89 | alist 90 | (flatten-once (map (lambda (pair) 91 | (list (symbol->keyword (car pair)) 92 | (cdr pair))) 93 | alist)))) 94 | 95 | (define-syntax define-layout 96 | (syntax-rules () 97 | ((_ name (opts ...) render) 98 | (define-layout name (opts ...) "" render)) 99 | ((_ name (opts ...) docstring render) 100 | (begin 101 | (define* (name #:key opts ... #:rest views) 102 | docstring 103 | (make-layout (procedure-name name) 104 | render 105 | (remove-keys views) 106 | (kvs->alist (only-keys views)))))))) 107 | 108 | (define (flatten-once ls) 109 | (apply append 110 | (map-in-order 111 | (lambda (v) 112 | (if (list? v) v (list v))) 113 | ls))) 114 | 115 | (define (cons-add a b) 116 | (cons (+ (car a) (car b)) 117 | (+ (cdr a) (cdr b)))) 118 | 119 | (define (shift-origins origin vols) 120 | (map (lambda (vol) 121 | (rview-set-origin vol (cons-add origin (rview-origin vol)))) 122 | vols)) 123 | 124 | (define-method (place (layout ) (output ) (origin ) (dims )) 125 | (if (null? (layout-views layout)) 126 | '() 127 | (let ((render (layout-render-fn layout))) 128 | (shift-origins origin (flatten-once (render (layout-views layout) (layout-opts layout) output dims)))))) 129 | 130 | (define (layout-with layout-fn views opts output dims) 131 | "Layout the given `views' with `layout-fn'. 132 | Use this function to compose layouts. A practical example of this is 133 | given in the `rows' layout, which is defined in terms of the `columns' 134 | layout. 135 | 136 | This function only needs to be used in the uppermost composed layout. 137 | Layouts nested within that can should be placed within the views list 138 | in their normal form. See `tall` for an example of this." 139 | (place (apply layout-fn (append (alist->kvs opts) views)) 140 | output '(0 . 0) dims)) 141 | 142 | (define (render-rview! rv) 143 | "Renders an individual rview onto the screen by setting the output 144 | and geometry of the view smob." 145 | (match rv 146 | (($ rview view output origin dimensions) 147 | (when (view-view? view) 148 | (begin 149 | (view-set-geometry view (cons origin dimensions)) 150 | (view-set-output view output)))) 151 | (_ #f))) 152 | 153 | (define (render! output zipper) 154 | "Render a layout zipper onto an output." 155 | (display "render! called on ") 156 | (display (unzip zipper)) 157 | (newline) 158 | (map render-rview! 159 | (place (unzip zipper) output '(0 . 0) (output-get-resolution output)))) 160 | -------------------------------------------------------------------------------- /test/types/view_spec.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | #include 5 | 6 | #include 7 | 8 | #include "../../src/types/view.h" 9 | 10 | START_TEST (test_view_init) 11 | { 12 | scm_init_guile (); 13 | /* this test depends on internals of guile. do not recommend */ 14 | init_gram_view (); 15 | scm_smob_descriptor ssd = scm_smobs[scm_numsmob - 1]; 16 | 17 | ck_assert_str_eq (ssd.name, "view"); 18 | } 19 | 20 | END_TEST 21 | START_TEST (test_view_convert) 22 | { 23 | scm_init_guile (); 24 | init_gram_view (); 25 | 26 | /* wlc_handle is a typedef of uint32_t. Calling any wlc_* functions 27 | on these WILL FAIL. However, it allows testing smob conversion in 28 | isolation. */ 29 | const wlc_handle a = 1, b = 2; 30 | 31 | SCM sa = gram_view_scm (a), sb = gram_view_scm (b); 32 | 33 | scm_assert_smob_type (gram_view_tag, sa); 34 | scm_assert_smob_type (gram_view_tag, sb); 35 | } 36 | 37 | END_TEST 38 | START_TEST (test_view_deactivate_basic) 39 | { 40 | scm_init_guile (); 41 | init_gram_view (); 42 | 43 | const wlc_handle a = 1; 44 | 45 | SCM sa = gram_view_scm (a); 46 | 47 | ck_assert (((struct gram_view *) SCM_SMOB_DATA (sa))->active); 48 | 49 | gram_view_deactivate (a); 50 | 51 | ck_assert (!((struct gram_view *) SCM_SMOB_DATA (sa))->active); 52 | } 53 | 54 | END_TEST 55 | START_TEST (test_view_reactivated_conversion) 56 | { 57 | /* conversion should reactivate a view because it is again safe to 58 | use. This is predicated on gram_view_scm only being called on 59 | active views, and gram_view_deactivate being called immediately 60 | when a view is closed. */ 61 | scm_init_guile (); 62 | init_gram_view (); 63 | 64 | const wlc_handle a = 1; 65 | 66 | SCM sa = gram_view_scm (a); 67 | 68 | ck_assert (((struct gram_view *) SCM_SMOB_DATA (sa))->active); 69 | 70 | gram_view_deactivate (a); 71 | SCM sa2 = gram_view_scm (a); 72 | 73 | ck_assert (((struct gram_view *) SCM_SMOB_DATA (sa2))->active); 74 | ck_assert (((struct gram_view *) SCM_SMOB_DATA (sa))->active); 75 | } 76 | 77 | END_TEST 78 | START_TEST (test_view_deactivate_fns) 79 | { 80 | /* it should be safe to call any gram_view_* fns on a deactivated 81 | view, regardless of WLC's state. */ 82 | scm_init_guile (); 83 | init_gram_view (); 84 | 85 | const wlc_handle a = 1; 86 | 87 | SCM sa = gram_view_scm (a); 88 | 89 | ck_assert (((struct gram_view *) SCM_SMOB_DATA (sa))->active); 90 | 91 | gram_view_deactivate (a); 92 | 93 | scm_c_use_module ("gram view"); 94 | ck_assert_ptr_eq (scm_call_1 95 | (scm_variable_ref (scm_c_lookup ("close")), sa), 96 | SCM_BOOL_T); 97 | /* mutations should return the view itself */ 98 | ck_assert_ptr_eq (scm_call_1 99 | (scm_variable_ref (scm_c_lookup ("focus")), sa), sa); 100 | ck_assert_ptr_eq (scm_call_1 101 | (scm_variable_ref (scm_c_lookup ("bring-to-front")), 102 | sa), sa); 103 | ck_assert_ptr_eq (scm_call_1 104 | (scm_variable_ref (scm_c_lookup ("send-to-back")), 105 | sa), sa); 106 | /* getters should return #f */ 107 | ck_assert_ptr_eq (scm_call_1 108 | (scm_variable_ref (scm_c_lookup ("get-geometry")), 109 | sa), SCM_BOOL_F); 110 | ck_assert_ptr_eq (scm_call_1 111 | (scm_variable_ref (scm_c_lookup ("get-state")), sa), 112 | SCM_BOOL_F); 113 | ck_assert_ptr_eq (scm_call_1 114 | (scm_variable_ref (scm_c_lookup ("get-output")), sa), 115 | SCM_BOOL_F); 116 | ck_assert_ptr_eq (scm_call_1 117 | (scm_variable_ref (scm_c_lookup ("get-app-id")), sa), 118 | SCM_BOOL_F); 119 | ck_assert_ptr_eq (scm_call_1 120 | (scm_variable_ref (scm_c_lookup ("get-class")), sa), 121 | SCM_BOOL_F); 122 | ck_assert_ptr_eq (scm_call_1 123 | (scm_variable_ref (scm_c_lookup ("get-types")), sa), 124 | SCM_BOOL_F); 125 | } 126 | 127 | END_TEST 128 | START_TEST (test_view_equalp_reflexive) 129 | { 130 | scm_init_guile (); 131 | init_gram_view (); 132 | 133 | const wlc_handle a = 1, b = 2; 134 | 135 | SCM sa = gram_view_scm (a), sb = gram_view_scm (b); 136 | 137 | ck_assert_ptr_eq (scm_equal_p (sa, sa), SCM_BOOL_T); 138 | ck_assert_ptr_eq (scm_equal_p (sb, sb), SCM_BOOL_T); 139 | } 140 | 141 | END_TEST 142 | START_TEST (test_view_equalp_pseudoreflexive) 143 | { 144 | /* if a == b then (equalp sa sb) */ 145 | scm_init_guile (); 146 | init_gram_view (); 147 | 148 | const wlc_handle a = 1, b = 1; 149 | 150 | SCM sa = gram_view_scm (a), sb = gram_view_scm (b); 151 | 152 | ck_assert_ptr_eq (scm_eq_p (sa, sb), SCM_BOOL_T); 153 | ck_assert_ptr_eq (scm_equal_p (sa, sb), SCM_BOOL_T); 154 | } 155 | 156 | END_TEST 157 | START_TEST (test_view_equalp_nontrivial) 158 | { 159 | /* if a != b then (not (equalp sa sb)) */ 160 | scm_init_guile (); 161 | init_gram_view (); 162 | 163 | const wlc_handle a = 1, b = 2; 164 | 165 | SCM sa = gram_view_scm (a), sb = gram_view_scm (b); 166 | 167 | ck_assert_ptr_eq (scm_equal_p (sa, sb), SCM_BOOL_F); 168 | } 169 | 170 | END_TEST Suite * 171 | view_suite (void) 172 | { 173 | Suite *s; 174 | TCase *tc_init, *tc_convert, *tc_deactivate, *tc_equalp; 175 | 176 | s = suite_create ("types/view"); 177 | 178 | tc_init = tcase_create ("init"); 179 | tcase_add_test (tc_init, test_view_init); 180 | suite_add_tcase (s, tc_init); 181 | 182 | tc_convert = tcase_create ("convert"); 183 | tcase_add_test (tc_convert, test_view_convert); 184 | suite_add_tcase (s, tc_convert); 185 | 186 | tc_deactivate = tcase_create ("deactivate"); 187 | tcase_add_test (tc_deactivate, test_view_deactivate_basic); 188 | tcase_add_test (tc_deactivate, test_view_reactivated_conversion); 189 | tcase_add_test (tc_deactivate, test_view_deactivate_fns); 190 | suite_add_tcase (s, tc_deactivate); 191 | 192 | tc_equalp = tcase_create ("equalp"); 193 | tcase_add_test (tc_equalp, test_view_equalp_reflexive); 194 | tcase_add_test (tc_equalp, test_view_equalp_pseudoreflexive); 195 | tcase_add_test (tc_equalp, test_view_equalp_nontrivial); 196 | suite_add_tcase (s, tc_equalp); 197 | 198 | return s; 199 | } 200 | 201 | int 202 | main (void) 203 | { 204 | int num_fail; 205 | Suite *s; 206 | SRunner *sr; 207 | 208 | s = view_suite (); 209 | sr = srunner_create (s); 210 | 211 | srunner_set_tap (sr, "-"); 212 | srunner_run_all (sr, CK_NORMAL); 213 | num_fail = srunner_ntests_failed (sr); 214 | srunner_free (sr); 215 | return (num_fail == 0) ? EXIT_SUCCESS : EXIT_FAILURE; 216 | } 217 | -------------------------------------------------------------------------------- /src/types/keysym.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include "keysym.h" 6 | 7 | bool gram_swallow = false; 8 | 9 | static SCM 10 | gram_keysym_equalp (SCM a, SCM b) 11 | { 12 | struct gram_keysym *k_a = (struct gram_keysym *) SCM_SMOB_DATA (a); 13 | struct gram_keysym *k_b = (struct gram_keysym *) SCM_SMOB_DATA (b); 14 | 15 | /* log relevant properties of both keysyms. Useful for debugging. */ 16 | /* printf("mouse: %d %d, button: %d %d, sym: %d %d, mods: %d %d\n", */ 17 | /* k_a->mouse, k_b->mouse, k_a->mouse_button, k_b->mouse_button, */ 18 | /* k_a->sym, k_b->sym, k_a->mods.mods, k_b->mods.mods); */ 19 | if (((k_a->mouse && k_b->mouse && k_a->mouse_button == k_b->mouse_button) 20 | || (!k_a->mouse && !k_b->mouse && k_a->sym == k_b->sym)) 21 | && k_a->mods.mods == k_b->mods.mods) { 22 | return SCM_BOOL_T; 23 | } 24 | 25 | return SCM_BOOL_F; 26 | } 27 | 28 | static int 29 | gram_keysym_print (SCM keysym_smob, SCM port, scm_print_state * pstate) 30 | { 31 | struct gram_keysym *keysym = 32 | (struct gram_keysym *) SCM_SMOB_DATA (keysym_smob); 33 | 34 | scm_puts ("#mods.mods & WLC_BIT_MOD_LOGO) 36 | { 37 | scm_puts ("S-", port); 38 | } 39 | if (keysym->mods.mods & WLC_BIT_MOD_CTRL) 40 | { 41 | scm_puts ("C-", port); 42 | } 43 | if (keysym->mods.mods & WLC_BIT_MOD_ALT) 44 | { 45 | scm_puts ("M-", port); 46 | } 47 | 48 | if(keysym->mouse) { 49 | scm_puts ("Mouse", port); 50 | scm_putc(keysym->mouse_button + '0', port); 51 | } else { 52 | char buf[64]; 53 | xkb_keysym_to_utf8 (keysym->sym, buf, 64); 54 | 55 | if (buf[0] > 0 && buf[0] <= 0x7F) 56 | { 57 | xkb_keysym_get_name (keysym->sym, buf, 64); 58 | } 59 | 60 | SCM name = scm_from_utf8_string (buf); 61 | scm_display (name, port); 62 | } 63 | scm_puts (">", port); 64 | 65 | return 1; 66 | } 67 | 68 | SCM 69 | gram_keysym_scm (struct gram_keysym * _keysym) 70 | { 71 | struct gram_keysym *keysym = (struct gram_keysym *) 72 | scm_gc_malloc (sizeof (struct gram_keysym), "keysym"); 73 | 74 | memcpy (keysym, _keysym, sizeof (struct gram_keysym)); 75 | 76 | return scm_new_smob (gram_keysym_tag, (scm_t_bits) keysym); 77 | } 78 | 79 | #define GRAM_NUM_SYMS 4 80 | uint32_t gram_keysym_from_name(char* name) { 81 | uint32_t sym = xkb_keysym_from_name(name, XKB_KEYSYM_CASE_INSENSITIVE); 82 | 83 | static uint32_t symbols[GRAM_NUM_SYMS][2] = {{'.', XKB_KEY_period }, 84 | {'$', XKB_KEY_dollar }, 85 | {',', XKB_KEY_comma }, 86 | {'#', XKB_KEY_numbersign}}; 87 | 88 | if(sym == XKB_KEY_NoSymbol && strlen(name) == 1) { 89 | /* check symbols */ 90 | for(int i = 0; i < GRAM_NUM_SYMS; i++) { 91 | if(name[0] == symbols[i][0]) { 92 | return symbols[i][1]; 93 | } 94 | } 95 | } 96 | return sym; 97 | } 98 | 99 | SCM 100 | gram_keysym_construct (SCM key_desc) 101 | { 102 | char *desc = scm_to_locale_string (key_desc); 103 | char *buf, *prev = NULL; 104 | 105 | struct gram_keysym keysym; 106 | keysym.mouse_button = -1; 107 | keysym.mouse = false; 108 | keysym.mods.mods = 0; 109 | keysym.mods.leds = 0; 110 | 111 | buf = strtok (desc, "-<>"); 112 | while (buf != NULL) 113 | { 114 | if (prev != NULL && strlen (prev) == 1) 115 | { 116 | switch (prev[0]) 117 | { 118 | case 'S': 119 | keysym.mods.mods |= WLC_BIT_MOD_LOGO; 120 | break; 121 | case 'C': 122 | keysym.mods.mods |= WLC_BIT_MOD_CTRL; 123 | break; 124 | case 'M': 125 | keysym.mods.mods |= WLC_BIT_MOD_ALT; 126 | break; 127 | default: 128 | /* invalid mod */ 129 | scm_misc_error ("kbd", "~A is not a valid modifier", 130 | scm_list_1 (scm_from_locale_string (prev))); 131 | return SCM_BOOL_F; 132 | } 133 | } 134 | /* TODO: wtf is this? */ 135 | /* else if (prev != NULL && strlen (prev) == 1) */ 136 | /* { */ 137 | /* scm_misc_error ("kbd", "~A is not a valid keysym", */ 138 | /* scm_list_1 (key_desc)); */ 139 | /* return SCM_BOOL_F; */ 140 | /* } */ 141 | keysym.sym = gram_keysym_from_name (buf); 142 | prev = buf; 143 | buf = strtok (NULL, "-<>"); 144 | } 145 | 146 | /* check for mouse-sym */ 147 | if (keysym.sym == XKB_KEY_NoSymbol && prev 148 | && strnlen(prev, 7) == 6 /* there are no double-digit mouse 149 | * buttons, and I defy you to show me 150 | * otherwise */ 151 | && strncmp(prev, "Mouse", 5) == 0) 152 | { 153 | /* if the symbol isn't matched by XKB, and the prev buffer is 154 | * non-null and begins with "Mouse", it is a Mouse-symbol */ 155 | 156 | /* TODO: representing mouse/scroll buttons? they don't have XKB 157 | * keysyms and I don't want to store them in the same way. */ 158 | keysym.mouse = true; 159 | keysym.mouse_button = atoi(&prev[5]); 160 | } 161 | else if (keysym.sym == XKB_KEY_NoSymbol) 162 | { 163 | scm_misc_error ("kbd", "~A is not a valid keysym", 164 | scm_list_1 (scm_from_locale_string (prev))); 165 | return SCM_BOOL_F; 166 | } 167 | 168 | return gram_keysym_scm (&keysym); 169 | } 170 | 171 | SCM 172 | gram_key_swallow_next (void) 173 | { 174 | gram_swallow = true; 175 | return SCM_BOOL_T; 176 | } 177 | 178 | SCM 179 | gram_keysym_unmodified (SCM keysym_smob) 180 | { 181 | scm_assert_smob_type(gram_keysym_tag, keysym_smob); 182 | struct gram_keysym *keysym = 183 | (struct gram_keysym *) SCM_SMOB_DATA (keysym_smob); 184 | struct gram_keysym copy; /* copying just to guarantee that I 185 | * don't corrupt the original */ 186 | memcpy(©,keysym, sizeof(struct gram_keysym)); 187 | 188 | copy.mods.mods = 0; 189 | 190 | return gram_keysym_scm(©); 191 | } 192 | 193 | void 194 | init_gram_keysym_fns (void *data) 195 | { 196 | scm_c_define_gsubr ("swallow-next-key", 0, 0, 0, gram_key_swallow_next); 197 | scm_c_define_gsubr ("kbd", 1, 0, 0, gram_keysym_construct); 198 | scm_c_define_gsubr ("unmodified", 1, 0, 0, gram_keysym_unmodified); 199 | 200 | scm_c_export ("swallow-next-key", "kbd", "unmodified", NULL); 201 | } 202 | 203 | void 204 | init_gram_keysym (void) 205 | { 206 | gram_keysym_tag = 207 | scm_make_smob_type ("keysym", sizeof (struct gram_keysym)); 208 | scm_set_smob_print (gram_keysym_tag, gram_keysym_print); 209 | scm_set_smob_equalp (gram_keysym_tag, gram_keysym_equalp); 210 | 211 | scm_c_define_module ("gram keysym", init_gram_keysym_fns, NULL); 212 | } 213 | -------------------------------------------------------------------------------- /lib/gram/lib/render-hooks.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram lib render-hooks) 2 | #:use-module (srfi srfi-26) 3 | #:use-module (srfi srfi-9) 4 | #:use-module (ice-9 match) 5 | #:use-module (ice-9 pretty-print) 6 | #:use-module (gram lib zipper) 7 | #:use-module (gram lib render) 8 | #:use-module ((gram lib layout) #:select (tall simple)) 9 | #:use-module ((gram view) #:renamer (symbol-prefix-proc 'view-)) 10 | #:use-module (gram view hooks) 11 | #:use-module ((gram output) #:renamer (symbol-prefix-proc 'output-)) 12 | #:use-module (gram output hooks) 13 | #:export (transform-workspace! transform-layout! current-view add-view re-render! 14 | containing-layer focus-layer)) 15 | 16 | (define %default-layout (tall)) 17 | (define %default-floating-layout (simple)) 18 | (define %output-list '()) 19 | (define %workspace-list '()) 20 | (define %current-output #nil) 21 | (define %current-workspace #nil) 22 | 23 | (define-record-type workspace 24 | (make-workspace name tiling-layout floating-layout float? focused) 25 | workspace? 26 | (name workspace-name set-workspace-name!) 27 | (focused focused-layout set-focused-layout!) 28 | (tiling-layout tiling-layout set-tiling-layout!) 29 | (floating-layout floating-layout set-floating-layout!) 30 | (float? float? set-float!)) 31 | 32 | (define (re-render!) 33 | (display "re-render! called") (newline) 34 | (render! %current-output (tiling-layout %current-workspace)) 35 | (render! %current-output (floating-layout %current-workspace))) 36 | 37 | (define (transform-workspace! layer f) 38 | "Transform the `layer' layout of the current workspace by applying f 39 | to the appropriate layout. 40 | 41 | `layer' should be either 'floating or 'tiling. 42 | 43 | `f' should be a function taking a layout zipper and returning another 44 | layout zipper." 45 | (case layer 46 | ((floating) (set-floating-layout! %current-workspace 47 | (f (floating-layout %current-workspace)))) 48 | ((tiling) (set-tiling-layout! %current-workspace 49 | (f (tiling-layout %current-workspace)))) 50 | ((both) (begin 51 | (transform-workspace! 'tiling f) 52 | (transform-workspace! 'floating f))))) 53 | 54 | (define (transform-layout! f) 55 | "Transform the currently focused layout by `f'. See the definition 56 | of `transform-workspace!' for more information." 57 | (transform-workspace! (focused-layout %current-workspace) f) 58 | (re-render!)) 59 | 60 | (define (current-view) 61 | (let ((vol (case (focused-layout %current-workspace) 62 | ((floating) (zipper-node (floating-layout %current-workspace))) 63 | ((tiling) (zipper-node (tiling-layout %current-workspace)))))) 64 | (if (view-view? vol) 65 | vol 66 | #f))) 67 | 68 | (define (containing-layer view) 69 | "Returns either 'tiling, 'floating, or #f describing which layer the 70 | view is contained in on the current workspace." 71 | (cond 72 | ((contains? (tiling-layout %current-workspace) view) 'tiling) 73 | ((contains? (floating-layout %current-workspace) view) 'floating) 74 | (else #f))) 75 | 76 | (define (focus-layer layer) 77 | "Focus the specified layer of the current workspace." 78 | (case layer 79 | [(tiling floating) (begin 80 | (set-focused-layout! %current-workspace layer) 81 | (when (current-view) 82 | (view-focus (current-view))))] 83 | [else #f])) 84 | 85 | (define (should-float? view) 86 | (let ((types (view-get-types view))) 87 | (not (null? types)))) 88 | 89 | (define (get-workspace name) 90 | "Get a workspace from the alist if it exists. If not, create it with 91 | the default tiling and floating layouts." 92 | (if (assoc name %workspace-list) 93 | (assoc-ref %workspace-list name) 94 | (let ((ws (make-workspace 95 | name 96 | (go (mkzip %default-layout) 'down) 97 | (go (mkzip %default-floating-layout) 'down) 98 | should-float? 99 | 'tiling))) 100 | (set! %workspace-list (acons name ws %workspace-list)) 101 | ws))) 102 | 103 | (define (get-first-unused-workspace out) 104 | "Returns the first workspace that is not used by any other output. 105 | If none exists, one is created. If the given output has a workspace 106 | already, it is returned." 107 | (if (assoc out %output-list) 108 | (assoc-ref %workspace-list (assoc-ref %output-list out)) 109 | (let* ((names (map car %workspace-list)) 110 | (used (map cadr %output-list)) 111 | (unused (filter (lambda (s) (not (member s used))) names))) 112 | (if (null? unused) 113 | (get-workspace (string-append "default-" (output-get-name out))) 114 | (get-workspace (car unused)))))) 115 | 116 | (define (output-created out) 117 | (set! %output-list (acons out (workspace-name (get-first-unused-workspace out)) %output-list))) 118 | 119 | (define (output-focused out focused?) 120 | (when focused? 121 | (unless (null? %current-output) 122 | (assoc-set! %output-list out (workspace-name %current-workspace))) 123 | (set! %current-output out) 124 | (set! %current-workspace (get-workspace (assoc-ref %output-list out))))) 125 | 126 | (define (hide-workspace! ws) 127 | "Hides all of the views in the workspace `ws'." 128 | (transform-workspace! 'both (lambda (z) (zmap z (lambda (v) (if (view-view? v) (view-hide v) v)))))) 129 | 130 | (define (show-workspace! ws out) 131 | "Shows all of the views in workspace `ws' on the output `out'." 132 | (transform-workspace! 'both (lambda (z) (zmap z (lambda (v) (if (view-view? v) (view-show v out) v)))))) 133 | 134 | (define (switch-to-workspace name) 135 | "Switch to the workspace named `name'. If it does not exist, it is 136 | created." 137 | (let ((ws (get-workspace name))) 138 | (hide-workspace! %current-workspace) 139 | (set! %current-workspace ws) 140 | (show-workspace! %current-workspace %current-output) 141 | (re-render!))) 142 | 143 | (define (zipper-in-layout? zipper) 144 | (let ((up (go zipper 'up))) 145 | (if (zipper? up) 146 | (layout? (zipper-node up)) 147 | #f))) 148 | 149 | (define (add-view zipper view) 150 | (when (zipper-in-layout? zipper) 151 | (z-> zipper 152 | (insert view 'right) 153 | (go 'right)))) 154 | 155 | (define (view-created view) 156 | (transform-workspace! (if ((float? %current-workspace) view) 157 | 'floating 'tiling) 158 | (cute add-view <> view)) 159 | (view-show view %current-output) 160 | (view-focus view) 161 | (view-bring-to-front view) 162 | (re-render!)) 163 | 164 | (define (top-level? z) 165 | (match z 166 | (($ zipper _ #f #f #f) #t) 167 | (_ #f))) 168 | 169 | (define (view-destroyed) 170 | (transform-workspace! 'both (lambda (z) (zfilter z view-active?))) 171 | (when (current-view) 172 | (view-focus (current-view))) 173 | (re-render!)) 174 | 175 | (define (view-handle-geometry view geo) 176 | (format #t "View ~a requested geometry ~a\n" view geo)) 177 | 178 | (add-hook! output-created-hook output-created) 179 | (add-hook! output-focus-hook output-focused) 180 | (add-hook! view-created-hook view-created) 181 | (add-hook! view-request-geometry-hook view-handle-geometry) 182 | (add-hook! view-destroyed-hook view-destroyed) 183 | -------------------------------------------------------------------------------- /lib/gram/lib/zipper.scm: -------------------------------------------------------------------------------- 1 | (define-module (gram lib zipper) 2 | #:use-module (srfi srfi-9 gnu) 3 | #:use-module (ice-9 match) 4 | #:use-module (oop goops) 5 | #:export (zipper? mkzip unzip set swap del 6 | zipper zipper-node 7 | insert go rotate 8 | extract children 9 | top find path replay transform z-> zmap zfilter 10 | contains?)) 11 | 12 | (define-immutable-record-type zipper 13 | (make-zipper node left up right) 14 | zipper? 15 | (node zipper-node) 16 | (left zipper-left) 17 | (up zipper-up) 18 | (right zipper-right)) 19 | 20 | (define (go-left z) 21 | (match z 22 | (($ zipper node (next rest ...) up right) 23 | (make-zipper next rest up (cons node right))) 24 | (_ #f))) 25 | 26 | (define (go-right z) 27 | (match z 28 | (($ zipper node left up (next rest ...)) 29 | (make-zipper next (cons node left) up rest)) 30 | (_ #f))) 31 | 32 | (define-generic extract) 33 | (define-method (extract (kids ) (old-parent )) 34 | kids) 35 | 36 | (define (go-up z) 37 | (match z 38 | (($ zipper #nil '() ($ zipper old left up right) '()) 39 | (make-zipper (extract '() old) 40 | left up right)) 41 | (($ zipper node left ($ zipper old uleft uup uright) right) 42 | (make-zipper (extract (append (reverse left) (list node) right) old) 43 | uleft uup uright)) 44 | (_ #f))) 45 | 46 | (define-generic children) 47 | (define-method (children (lst )) lst) 48 | (define-method (children atom) #f) 49 | 50 | (define (leaf? z) 51 | (eq? #f (children z))) 52 | 53 | (define (go-down z) 54 | (match z 55 | (($ zipper node _ _ _) 56 | (let ((kids (children node))) 57 | (cond 58 | ((eq? #f kids) #f) 59 | ((null? kids) (make-zipper #nil '() z '())) 60 | (#t (make-zipper (car kids) '() z (cdr kids)))))) 61 | (_ #f))) 62 | 63 | (define (insert-right z new) 64 | (match z 65 | (($ zipper #nil '() _ '()) 66 | (set z new)) 67 | (($ zipper node left up right) 68 | (make-zipper node left up (cons new right))) 69 | (_ #f))) 70 | 71 | (define (insert-left z new) 72 | (match z 73 | (($ zipper #nil '() _ '()) 74 | (set z new)) 75 | (($ zipper node left up right) 76 | (make-zipper node (cons new left) up right)) 77 | (_ #f))) 78 | 79 | (define (rotate-left z) 80 | (match z 81 | [($ zipper node (left rest ...) up right) 82 | (make-zipper left (cons node rest) up right)] 83 | [_ #f])) 84 | 85 | (define (rotate-right z) 86 | (match z 87 | [($ zipper node left up (right rest ...)) 88 | (make-zipper right left up (cons node rest))] 89 | [_ #f])) 90 | 91 | (define (go z dir) 92 | (case dir 93 | ((left) (go-left z)) 94 | ((right) (go-right z)) 95 | ((up) (go-up z)) 96 | ((down) (go-down z)) 97 | (else #f))) 98 | 99 | (define (rotate z dir) 100 | (case dir 101 | ((left) (rotate-left z)) 102 | ((right) (rotate-right z)) 103 | (else #f))) 104 | 105 | (define (insert z new dir) 106 | (case dir 107 | ((left) (insert-left z new)) 108 | ((right) (insert-right z new)) 109 | (else #f))) 110 | (define (set z new) 111 | (match z 112 | (($ zipper _ left up right) 113 | (make-zipper new left up right)) 114 | (_ #f))) 115 | 116 | (define (swap z f . args) 117 | (set z (apply f (zipper-node z) args))) 118 | 119 | (define (del z) 120 | (match z 121 | (($ zipper node left up (next rest ...)) 122 | (make-zipper next left up rest)) 123 | (($ zipper node (next rest ...) up '()) 124 | (make-zipper next rest up '())) 125 | (($ zipper node '() up '()) 126 | (make-zipper #nil '() up '())) 127 | (($ zipper _ #f #f #f) 128 | (make-zipper #nil #f #f #f)) 129 | (_ #f))) 130 | 131 | (define (unzip z) 132 | (match z 133 | (($ zipper node #f #f #f) 134 | node) 135 | (($ zipper _ _ _ _) 136 | (unzip (go-up z))) 137 | (_ #f))) 138 | 139 | (define (mkzip l) 140 | (make-zipper l #f #f #f)) 141 | 142 | (define (top z) 143 | (mkzip (unzip z))) 144 | 145 | (define (find-dfs p? z) 146 | (if (or (not (zipper? z)) (p? (zipper-node z))) 147 | z 148 | (let ((down (find-dfs p? (go z 'down)))) 149 | (if down 150 | down 151 | (find-dfs p? (go z 'right)))))) 152 | 153 | (define (find z p?) 154 | (find-dfs p? (top z))) 155 | 156 | (define (path z) 157 | (match z 158 | (($ zipper node #f #f #f) 159 | '()) 160 | (($ zipper _ '() _ _) 161 | (append (path (go z 'up)) (list 'down))) 162 | (($ zipper _ (a b ...) _ _) 163 | (append (path (go z 'left)) (list 'right))) 164 | (_ #f))) 165 | 166 | (define (replay z path) 167 | (if (null? path) 168 | z 169 | (or (replay (go z (car path)) (cdr path)) z))) 170 | 171 | (define (transform z p? f . rest) 172 | "Transforms the given zipper by finding the first element `dst` 173 | satisfying predicate `p?', calling `(apply f dst rest)`, and then 174 | returning to the original position. 175 | 176 | If `p?' does not satisfy `procedure?' then it is instead compared with 177 | `equal?'." 178 | (let ((track (path z)) 179 | (dst (find z (if (procedure? p?) 180 | p? 181 | (lambda (x) (equal? p? x)))))) 182 | (if dst 183 | (replay (top (apply f dst rest)) track) 184 | z))) 185 | 186 | (define (find-dfs p? z) 187 | (if (or (not (zipper? z)) (p? (zipper-node z))) 188 | z 189 | (let ((down (find-dfs p? (go z 'down)))) 190 | (if down 191 | down 192 | (find-dfs p? (go z 'right)))))) 193 | 194 | (define-syntax z-> 195 | (syntax-rules () 196 | [(z-> z (xform args ...)) 197 | (or (xform z args ...) z)] 198 | [(z-> z (xform args ...) xforms ...) 199 | (let [(zp (xform z args ...))] 200 | (if zp 201 | (z-> zp xforms ...) 202 | z))])) 203 | 204 | (define (-zmap z f) 205 | (if (zipper? z) 206 | (let* ((down (z-> z 207 | (swap f) 208 | (go 'down) 209 | (-zmap f) 210 | (go 'up)))) 211 | (z-> down 212 | (go 'right) 213 | (-zmap f))) 214 | #f)) 215 | 216 | (define (zmap z f . rest) 217 | "Applies f x rest to each leaf node of zipper `z' in depth-first 218 | order." 219 | (let ((track (path z)) 220 | (result (-zmap (top z) (lambda (x) (if (leaf? x) (apply f x rest) x))))) 221 | (replay (top result) track))) 222 | 223 | (define (-zfilter z p?) 224 | (if (zipper? z) 225 | (let ((zp (if (p? (zipper-node z)) z (del z)))) 226 | (let* ((next* (z-> zp (go 'down) (-zfilter p?) (go 'up))) 227 | (next (if (null? (zipper-node next*)) 228 | (del next*) 229 | next*))) 230 | (z-> next (go 'right) (-zfilter p?)))) 231 | #f)) 232 | 233 | (define (zfilter z p? . rest) 234 | "Returns the zipper containing the leaf elements of `z' which 235 | satisfy (apply p? x rest)." 236 | (let ((track (path z)) 237 | (result (-zfilter (top z) (lambda (x) 238 | (or (not (leaf? x)) 239 | (apply p? x rest)))))) 240 | (replay (top result) track))) 241 | 242 | (define (contains? z x) 243 | (not (eq? #f (find z (lambda (y) (equal? x y)))))) 244 | -------------------------------------------------------------------------------- /src/types/output.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include "output.h" 6 | #include "view.h" 7 | 8 | static struct gram_output *output_table[GRAM_MAX_OUTPUTS]; 9 | static SCM smob_table[GRAM_MAX_VIEWS]; 10 | 11 | static int 12 | gram_output_print (SCM output_smob, SCM port, scm_print_state * pstate) 13 | { 14 | struct gram_output *output = 15 | (struct gram_output *) SCM_SMOB_DATA (output_smob); 16 | 17 | const char *name = wlc_output_get_name (output->output); 18 | scm_puts ("#", port); 21 | 22 | return 1; 23 | } 24 | 25 | SCM 26 | gram_output_scm (const wlc_handle output) 27 | { 28 | uint32_t i; 29 | for (i = 0; i < GRAM_MAX_OUTPUTS; i++) 30 | { 31 | if (output_table[i] && output_table[i]->output == output) 32 | { 33 | break; 34 | } 35 | } 36 | 37 | /* output not in table */ 38 | if (i >= GRAM_MAX_OUTPUTS) 39 | { 40 | for (i = 0; i < GRAM_MAX_OUTPUTS; i++) 41 | { 42 | if (output_table[i] == NULL) 43 | { 44 | output_table[i] = (struct gram_output *) 45 | scm_gc_malloc_pointerless (sizeof (struct gram_output), "output"); 46 | 47 | *(wlc_handle *) & output_table[i]->output = output; 48 | smob_table[i] = 49 | scm_new_smob (gram_output_tag, (scm_t_bits) output_table[i]); 50 | break; 51 | } 52 | } 53 | } 54 | 55 | if (i >= GRAM_MAX_OUTPUTS) 56 | { 57 | /* still no room */ 58 | return SCM_ELISP_NIL; 59 | } 60 | output_table[i]->active = true; 61 | return smob_table[i]; 62 | } 63 | 64 | /* Marks the table entry corresponding to `output` as invalid if it 65 | exists. */ 66 | void 67 | gram_output_deactivate (const wlc_handle output) 68 | { 69 | uint32_t i; 70 | for (i = 0; i < GRAM_MAX_OUTPUTS; i++) 71 | { 72 | if (output_table[i] && output_table[i]->output == output) 73 | { 74 | output_table[i]->active = false; 75 | } 76 | } 77 | } 78 | 79 | /* Removes the table entry corresponding to `output`. */ 80 | static size_t 81 | gram_output_free (SCM _output) 82 | { 83 | uint32_t i; 84 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 85 | for (i = 0; i < GRAM_MAX_OUTPUTS; i++) 86 | { 87 | if (output_table[i] == output) 88 | { 89 | output_table[i] = NULL; 90 | smob_table[i] = NULL; 91 | } 92 | } 93 | 94 | scm_gc_free (output, sizeof (struct gram_output), "output"); 95 | return 0; 96 | } 97 | 98 | SCM 99 | gram_output_focus (SCM _output) 100 | { 101 | scm_assert_smob_type (gram_output_tag, _output); 102 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 103 | if (output->active) 104 | { 105 | wlc_output_focus (output->output); 106 | return _output; 107 | } 108 | return SCM_ELISP_NIL; 109 | } 110 | 111 | SCM 112 | gram_output_get_name (SCM _output) 113 | { 114 | scm_assert_smob_type (gram_output_tag, _output); 115 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 116 | if (output->active) 117 | { 118 | return scm_from_locale_string (wlc_output_get_name (output->output)); 119 | } 120 | return SCM_ELISP_NIL; 121 | } 122 | 123 | SCM 124 | gram_output_get_views (SCM _output) 125 | { 126 | scm_assert_smob_type (gram_output_tag, _output); 127 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 128 | if (output->active) 129 | { 130 | size_t num_views; 131 | const wlc_handle *views = 132 | wlc_output_get_views (output->output, &num_views); 133 | SCM arr = scm_make_array (SCM_UNSPECIFIED, 134 | scm_list_1 (scm_from_uint32 (num_views))); 135 | 136 | scm_t_array_handle handle; 137 | scm_array_get_handle (arr, &handle); 138 | SCM *els = scm_array_handle_writable_elements (&handle); 139 | 140 | for (size_t i = 0; i < num_views; i++) 141 | { 142 | els[i] = gram_view_scm (views[i]); 143 | } 144 | 145 | scm_array_handle_release (&handle); 146 | 147 | return arr; 148 | } 149 | return SCM_ELISP_NIL; 150 | } 151 | 152 | SCM 153 | gram_output_get_resolution (SCM _output) 154 | { 155 | scm_assert_smob_type (gram_output_tag, _output); 156 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 157 | if (output->active) 158 | { 159 | const struct wlc_size *size = wlc_output_get_resolution (output->output); 160 | if (!size) 161 | { 162 | return SCM_BOOL_F; 163 | } 164 | return scm_cons (scm_from_uint32 (size->w), scm_from_uint32 (size->h)); 165 | } 166 | return SCM_ELISP_NIL; 167 | } 168 | 169 | SCM 170 | gram_output_get_sleep (SCM _output) 171 | { 172 | scm_assert_smob_type (gram_output_tag, _output); 173 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 174 | if (output->active) 175 | { 176 | return scm_from_bool (wlc_output_get_sleep (output->output)); 177 | } 178 | return SCM_ELISP_NIL; 179 | } 180 | 181 | SCM 182 | gram_output_set_views (SCM _output, SCM _views) 183 | { 184 | scm_assert_smob_type (gram_output_tag, _output); 185 | if (!scm_list_p (_views)) 186 | return SCM_BOOL_F; 187 | 188 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 189 | if (output->active) 190 | { 191 | /* somewhat complex code. we have to loop over the input view list 192 | * and extract the wlc_handles. we should ignore any inactive 193 | * input views. unsure if I need to free *views or not */ 194 | size_t num_views = scm_to_uint64 (scm_length (_views)); 195 | wlc_handle *views = calloc (sizeof (wlc_handle), num_views); 196 | SCM cur = _views; 197 | size_t i = 0; 198 | while (!scm_null_p (cur)) 199 | { 200 | SCM _view = scm_car (cur); 201 | _views = scm_cdr (cur); 202 | scm_assert_smob_type (gram_view_tag, _view); 203 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 204 | if (view->active) 205 | { 206 | views[i] = view->view; 207 | i++; 208 | } 209 | else 210 | { 211 | /* no view, reduce number of views */ 212 | num_views--; 213 | } 214 | } 215 | wlc_output_set_views (output->output, views, num_views); 216 | free (views); 217 | return _output; 218 | } 219 | return SCM_BOOL_F; 220 | } 221 | 222 | SCM 223 | gram_output_set_resolution (SCM _output, SCM _res) 224 | { 225 | scm_assert_smob_type (gram_output_tag, _output); 226 | if (!scm_pair_p (_res)) 227 | return SCM_ELISP_NIL; 228 | 229 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 230 | if (output->active) 231 | { 232 | struct wlc_size res; 233 | res.w = scm_to_uint32 (scm_car (_res)); 234 | res.h = scm_to_uint32 (scm_cdr (_res)); 235 | wlc_output_set_resolution (output->output, &res); 236 | return _output; 237 | } 238 | return SCM_ELISP_NIL; 239 | } 240 | 241 | SCM 242 | gram_output_set_sleep (SCM _output, SCM _sleep) 243 | { 244 | scm_assert_smob_type (gram_output_tag, _output); 245 | if (!scm_boolean_p (_sleep)) 246 | return SCM_ELISP_NIL; 247 | 248 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 249 | if (output->active) 250 | { 251 | wlc_output_set_sleep (output->output, scm_to_bool (_sleep)); 252 | return _output; 253 | } 254 | return SCM_ELISP_NIL; 255 | } 256 | 257 | SCM 258 | gram_output_schedule_render (SCM _output) 259 | { 260 | scm_assert_smob_type (gram_output_tag, _output); 261 | 262 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 263 | if (output->active) 264 | { 265 | wlc_output_schedule_render (output->output); 266 | printf ("scheduled a render\n"); 267 | return _output; 268 | } 269 | return SCM_ELISP_NIL; 270 | } 271 | 272 | void 273 | init_gram_output_methods (void *ignore) 274 | { 275 | scm_c_define_gsubr ("focus", 1, 0, 0, gram_output_focus); 276 | scm_c_define_gsubr ("get-name", 1, 0, 0, gram_output_get_name); 277 | scm_c_define_gsubr ("get-views", 1, 0, 0, gram_output_get_views); 278 | scm_c_define_gsubr ("get-resolution", 1, 0, 0, gram_output_get_resolution); 279 | scm_c_define_gsubr ("get-sleep", 1, 0, 0, gram_output_get_sleep); 280 | scm_c_define_gsubr ("set-views", 2, 0, 0, gram_output_set_views); 281 | scm_c_define_gsubr ("set-resolution", 2, 0, 0, gram_output_set_resolution); 282 | scm_c_define_gsubr ("set-sleep", 2, 0, 0, gram_output_set_sleep); 283 | scm_c_define_gsubr ("schedule-render", 1, 0, 0, 284 | gram_output_schedule_render); 285 | scm_c_export ("focus", "schedule-render", 286 | /* "get-mask", */ "get-views", 287 | /* "get-mutable-views", */ 288 | "get-name", "get-resolution", "get-sleep", 289 | /* "set-mask", */ "set-resolution", "set-sleep", "set-views", 290 | NULL); 291 | } 292 | 293 | void 294 | init_gram_output (void) 295 | { 296 | for (uint32_t i = 0; i < GRAM_MAX_OUTPUTS; i++) 297 | { 298 | output_table[i] = NULL; 299 | smob_table[i] = NULL; 300 | } 301 | 302 | gram_output_tag = 303 | scm_make_smob_type ("output", sizeof (struct gram_output)); 304 | scm_set_smob_print (gram_output_tag, gram_output_print); 305 | scm_set_smob_free (gram_output_tag, gram_output_free); 306 | 307 | scm_c_define_module ("gram output", init_gram_output_methods, NULL); 308 | } 309 | -------------------------------------------------------------------------------- /test/lib/zipper_spec.scm: -------------------------------------------------------------------------------- 1 | (use-modules (srfi srfi-9 gnu) 2 | (oop goops) 3 | (gram lib zipper) 4 | (gram support test-setup)) 5 | 6 | (describe "(gram lib zipper)" 7 | (describe "mkzip" 8 | (it "should return a zipper" 9 | (zipper? (mkzip '(a b c d))))) 10 | 11 | (describe "unzip" 12 | (it "should return #f for non-zippers" 13 | (and 14 | (not (unzip '(a b c))) 15 | (not (unzip 2.7)))) 16 | (it "should return the tree stored in the zipper" 17 | (equal? '(a b c d) (unzip (mkzip '(a b c d)))))) 18 | 19 | (describe "go" 20 | (describe "left" 21 | (it "should return #f for non-zippers" 22 | (not (go #f 'left))) 23 | (it "should return #f if there is nothing to the left" 24 | (not (go (mkzip '(a b c d)) 'left))) 25 | (it "should return a zipper to the left otherwise" 26 | (equal? 'a (zipper-node (z-> (mkzip '(a b c d)) 27 | (go 'down) 28 | (go 'right) 29 | (go 'left)))))) 30 | 31 | (describe "right" 32 | (it "should return #f for non-zippers" 33 | (not (go #f 'right))) 34 | (it "should return #f if there is nothing to the right" 35 | (not (go (go (go (mkzip '(a b)) 'down) 'right) 'right))) 36 | (it "should return a zipper to the right otherwise" 37 | (equal? 'b (zipper-node (z-> (mkzip '(a b c d)) 38 | (go 'down) 39 | (go 'right)))))) 40 | 41 | (define-immutable-record-type zippable-test 42 | (make-zt children other) 43 | zt? 44 | (children zt-children set-zt-children) 45 | (other zt-other)) 46 | 47 | (define-method (children (zt )) 48 | (zt-children zt)) 49 | 50 | (define-method (extract kids (old-zt )) 51 | (set-zt-children old-zt kids)) 52 | 53 | (describe "up" 54 | (it "should return #f for non-zippers" 55 | (not (go #f 'up))) 56 | (it "should return #f if there is nothing upwards" 57 | (not (go (mkzip '(a b c d)) 'up))) 58 | (it "should return a zipper up otherwise" 59 | (equal? '(a) (zipper-node (z-> (mkzip '((a) b c)) 60 | (go 'down) 61 | (go 'down) 62 | (go 'up))))) 63 | (it "should use `extract' to go up from inside a record" 64 | (equal? (make-zt '(a b) 'c) 65 | (zipper-node (z-> (mkzip (make-zt '(a) 'c)) 66 | (go 'down) 67 | (insert 'b 'right) 68 | (go 'up)))))) 69 | 70 | (describe "down" 71 | (it "should return #f for non-zippers" 72 | (not (go #f 'down))) 73 | (it "should return #f if there is nothing downwards" 74 | (not (go (go (mkzip '(a b c d)) 'down) 'down))) 75 | (it "should return a zipper down otherwise" 76 | (equal? 'a (zipper-node (z-> (mkzip '((a) b c)) 77 | (go 'down) 78 | (go 'down))))) 79 | (it "should use `children' to go down into a record" 80 | (equal? 'a 81 | (zipper-node (z-> (mkzip (make-zt '(a) 'c)) 82 | (go 'down))))))) 83 | 84 | (describe "insert" 85 | (describe "left" 86 | (it "should return #f for non-zippers" 87 | (not (insert #f 'a 'left))) 88 | (it "should add an element to the left" 89 | (equal? '(a b) (unzip (z-> (mkzip '(b)) 90 | (go 'down) 91 | (insert 'a 'left))))) 92 | (it "should leave the same node focused" 93 | (let ((z (go (mkzip '(b)) 'down))) 94 | (equal? (zipper-node z) (zipper-node (insert z 'a 'left))))) 95 | (it "should add an element to the left -- even when nested" 96 | (equal? '((b) (a c)) (unzip (z-> (mkzip '((b) (c))) 97 | (go 'down) 98 | (go 'right) 99 | (go 'down) 100 | (insert 'a 'left)))))) 101 | 102 | (describe "right" 103 | (it "should return #f for non-zippers" 104 | (not (insert #f 'a 'right))) 105 | (it "should effectively set for the empty zipper" 106 | (equal? '(a) (unzip (z-> (mkzip '()) 107 | (go 'down) 108 | (insert 'a 'right))))) 109 | (it "should add an element to the right" 110 | (equal? '(b a) (unzip (z-> (mkzip '(b)) 111 | (go 'down) 112 | (insert 'a 'right))))) 113 | (it "should leave the same node focused" 114 | (let ((z (go (mkzip '(b)) 'down))) 115 | (equal? (zipper-node z) (zipper-node (insert z 'a 'right))))) 116 | (it "should add an element to the right -- even when nested" 117 | (equal? '((b) (c a)) (unzip (z-> (mkzip '((b) (c))) 118 | (go 'down) 119 | (go 'right) 120 | (go 'down) 121 | (insert 'a 'right))))))) 122 | 123 | (describe "set" 124 | (it "should return #f for non-zippers" 125 | (not (set #f 'a))) 126 | (it "should replace the current node in the new zipper" 127 | (equal? '(b) (unzip (set (go (mkzip '(a)) 'down) 'b)))) 128 | (it "should replace the current node in the new zipper -- even when nested" 129 | (equal? '((b) (a)) (unzip (z-> (mkzip '((b) (c))) 130 | (go 'down) 131 | (go 'right) 132 | (go 'down) 133 | (set 'a)))))) 134 | 135 | (describe "del" 136 | (it "should return #f for non-zippers" 137 | (not (del 'a))) 138 | (it "should replace the current node with #nil if no right or left" 139 | (equal? #nil (zipper-node (del (go (mkzip '(a)) 'down))))) 140 | (it "should replace the current node with (car right) if it exists" 141 | (equal? 'b (zipper-node (del (go (mkzip '(a b)) 'down))))) 142 | (it "should replace the current node with (car left) if it exists but not (car right)" 143 | (equal? 'a (zipper-node (z-> (mkzip '(a b)) 144 | (go 'down) 145 | (go 'right) 146 | (del))))) 147 | (it "should remove the element from the zipper entirely" 148 | (equal? '() (unzip (del (go (mkzip '(a)) 'down)))))) 149 | 150 | (describe "path" 151 | (it "should return #f for non-zippers" 152 | (not (path 'a))) 153 | (it "should return the empty list if at the top of the zipper" 154 | (null? (path (mkzip '(a))))) 155 | (it "should return the sequence to reach the current zipper position otherwise" 156 | (equal? (list 'down 'right 'down) 157 | (path (z-> (mkzip '(a (b c))) 158 | (go 'down) 159 | (go 'right) 160 | (go 'down)))))) 161 | 162 | (describe "replay" 163 | (it "should return z itself for an empty path" 164 | (let ((z (mkzip '(a)))) 165 | (eq? (replay z '()) z))) 166 | (it "should return z after the steps in the path have been applied" 167 | (let ((z (mkzip '(a (b c))))) 168 | (equal? (replay z (list 'down 'right 'down)) 169 | (z-> z (go 'down) (go 'right) (go 'down)))))) 170 | 171 | (describe "transform" 172 | (it "should return z itself if z is not a zipper" 173 | (eq? 'a (transform 'a 'b identity))) 174 | (it "should return z itself if the element is not in z" 175 | (let ((z (mkzip '(a (b c))))) 176 | (eq? z (transform z 'd del)))) 177 | (it "should return z with the element transformed by `f dst . rest` otherwise" 178 | (let ((z (mkzip '(a (b c)))) 179 | (zp (mkzip '(a (b))))) 180 | (equal? zp (transform z 'c del)))) 181 | (it "should return a zipper in the same position" 182 | (let ((z (z-> (mkzip '(a (b c))) 183 | (go 'down) 184 | (go 'right))) 185 | (zp (z-> (mkzip '(a (b))) 186 | (go 'down) 187 | (go 'right)))) 188 | (equal? zp (transform z 'c del))))) 189 | 190 | (describe "zmap" 191 | (it "should map the leaf nodes of the zipper" 192 | (let ((z (mkzip (list 1 (list 2 3) 4))) 193 | (zp (mkzip (list 2 (list 3 4) 5)))) 194 | (equal? zp (zmap z 1+)))) 195 | (it "should map from the top" 196 | (let ((z (mkzip (list 1 (list 2 3) 4))) 197 | (zp (mkzip (list 2 (list 3 4) 5)))) 198 | (equal? zp (top (zmap (z-> z (go 'down) (go 'right) (go 'down)) 1+)))))) 199 | 200 | (describe "zfilter" 201 | (it "should filter the leaf nodes of the zipper" 202 | (let ((z (mkzip (list 1 'a (list 'b 2) 3 'c))) 203 | (zp (mkzip '(a (b) c)))) 204 | (equal? zp (zfilter z symbol?)))) 205 | (it "should filter from the top" 206 | (let ((z (mkzip (list 1 'a (list 'b 2) 3 'c))) 207 | (zp (mkzip '(a (b) c)))) 208 | (equal? zp (top (zfilter (z-> z (go 'down) (go 'right) (go 'down)) symbol?))))))) 209 | -------------------------------------------------------------------------------- /src/gram.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | #include 7 | #include 8 | 9 | #include "config.h" 10 | #include "types/types.h" 11 | #include "hooks/hooks.h" 12 | 13 | static SCM 14 | gram_terminate (void) { 15 | wlc_terminate(); 16 | return SCM_UNSPECIFIED; 17 | } 18 | 19 | static bool 20 | keyboard_key (wlc_handle view, uint32_t time, 21 | const struct wlc_modifiers *modifiers, uint32_t key, 22 | enum wlc_key_state state) 23 | { 24 | (void) time, (void) key; 25 | 26 | struct wlc_modifiers mods; 27 | 28 | memcpy (&mods, modifiers, sizeof (mods)); 29 | 30 | struct gram_keysym keysym = { 31 | .keycode = key, 32 | .sym = wlc_keyboard_get_keysym_for_key (key, NULL), 33 | .mods = mods, 34 | .mouse = false, 35 | .mouse_button = -1 36 | }; 37 | 38 | if (state == WLC_KEY_STATE_PRESSED) 39 | { 40 | struct keydown_input input = { 41 | .view = view, 42 | .keysym = keysym 43 | }; 44 | bool t = (SCM) gram_call_hook (gram_keydown_hook_run, &input) == SCM_BOOL_T; 45 | gram_swallow = false; 46 | return t; 47 | } 48 | else if (state == WLC_KEY_STATE_RELEASED) 49 | { 50 | struct keyup_input input = { 51 | .view = view, 52 | .keysym = keysym 53 | }; 54 | bool t = (SCM) gram_call_hook (gram_keyup_hook_run, &input) == SCM_BOOL_T; 55 | gram_swallow = false; 56 | return t; 57 | } 58 | 59 | return false; 60 | } 61 | 62 | static bool 63 | view_created (wlc_handle view) 64 | { 65 | gram_call_hook(gram_view_created_hook_run, &view); 66 | 67 | return true; 68 | } 69 | 70 | static void 71 | view_destroyed (wlc_handle view) 72 | { 73 | /* free the view and then run the hooks */ 74 | gram_view_deactivate (view); 75 | gram_call_hook (gram_view_destroyed_hook_run, NULL); 76 | } 77 | 78 | static void 79 | view_focus (wlc_handle view, bool focus) 80 | { 81 | struct view_focus_input input = { 82 | .handle = view, 83 | .focus = focus 84 | }; 85 | 86 | wlc_view_set_state (view, WLC_BIT_ACTIVATED, focus); 87 | gram_call_hook (gram_view_focus_hook_run, &input); 88 | } 89 | 90 | static void 91 | view_move_to_output (wlc_handle view, wlc_handle from, wlc_handle to) 92 | { 93 | struct move_to_output_input input = { 94 | .view = view, 95 | .from_out = from, 96 | .to_out = to 97 | }; 98 | 99 | gram_call_hook (gram_view_move_to_output_hook_run, &input); 100 | } 101 | 102 | static void 103 | view_request_geometry (wlc_handle view, const struct wlc_geometry *geo) 104 | { 105 | struct view_geo s = { 106 | view, geo 107 | }; 108 | 109 | gram_call_hook (gram_view_request_geometry_hook_run, &s); 110 | } 111 | 112 | static void 113 | view_render_pre (wlc_handle view) 114 | { 115 | gram_call_hook (gram_view_render_pre_hook_run, &view); 116 | } 117 | 118 | static void 119 | view_render_post (wlc_handle view) 120 | { 121 | gram_call_hook (gram_view_render_post_hook_run, &view); 122 | } 123 | 124 | static bool 125 | output_created (wlc_handle output) 126 | { 127 | gram_call_hook (gram_output_created_hook_run, &output); 128 | return true; 129 | } 130 | 131 | static void 132 | output_destroyed (wlc_handle output) 133 | { 134 | gram_call_hook (gram_output_destroyed_hook_run, &output); 135 | } 136 | 137 | static void 138 | output_focus (wlc_handle output, bool focus) 139 | { 140 | struct output_focus_input input = { 141 | .handle = output, 142 | .focus = focus 143 | }; 144 | gram_call_hook (gram_output_focus_hook_run, &input); 145 | } 146 | 147 | static void 148 | output_resolution (wlc_handle output, const struct wlc_size *from, 149 | const struct wlc_size *to) 150 | { 151 | struct resolution_input input = { 152 | .handle = output, 153 | .from = from, 154 | .to = to 155 | }; 156 | gram_call_hook (gram_output_resolution_hook_run, &input); 157 | } 158 | 159 | static void 160 | output_render_pre (wlc_handle output) 161 | { 162 | gram_call_hook (gram_output_render_pre_hook_run, &output); 163 | } 164 | 165 | static void 166 | output_render_post (wlc_handle output) 167 | { 168 | gram_call_hook (gram_output_render_post_hook_run, &output); 169 | } 170 | 171 | static bool 172 | pointer_motion (wlc_handle view, uint32_t time, const struct wlc_point *point) 173 | { 174 | struct pointer_motion_input input = { 175 | .view = view, 176 | .time = time, 177 | .point = point 178 | }; 179 | gram_call_hook (gram_pointer_motion_hook_run, &input); 180 | /* pointer motion always goes to the target view */ 181 | wlc_pointer_set_position (point); 182 | return false; 183 | } 184 | 185 | static bool 186 | pointer_button (wlc_handle view, uint32_t time, const struct wlc_modifiers *modifiers, 187 | uint32_t button, enum wlc_button_state state, 188 | const struct wlc_point *point) 189 | { 190 | struct wlc_modifiers mods; 191 | 192 | memcpy (&mods, modifiers, sizeof (mods)); 193 | 194 | struct gram_keysym keysym = { 195 | .keycode = 0, 196 | .sym = 0, 197 | .mods = mods, 198 | .mouse = true, 199 | /* the magic number 272 appears to be what mouse button 1 is */ 200 | .mouse_button = button - 271 201 | }; 202 | 203 | if (state == WLC_BUTTON_STATE_PRESSED) 204 | { 205 | struct keydown_input input = { 206 | .view = view, 207 | .keysym = keysym 208 | }; 209 | bool t = (SCM) gram_call_hook (gram_keydown_hook_run, &input) == SCM_BOOL_T; 210 | gram_swallow = false; 211 | return t; 212 | } 213 | else if (state == WLC_BUTTON_STATE_RELEASED) 214 | { 215 | struct keyup_input input = { 216 | .view = view, 217 | .keysym = keysym 218 | }; 219 | bool t = (SCM) gram_call_hook (gram_keyup_hook_run, &input) == SCM_BOOL_T; 220 | gram_swallow = false; 221 | return t; 222 | } 223 | 224 | return false; 225 | } 226 | 227 | static void 228 | compositor_ready () 229 | { 230 | gram_call_hook (gram_compositor_ready_hook_run, NULL); 231 | } 232 | 233 | static void 234 | compositor_terminate () 235 | { 236 | gram_call_hook (gram_compositor_terminate_hook_run, NULL); 237 | } 238 | 239 | static void * 240 | load_init (void *data) 241 | { 242 | scm_variable_set_x (scm_c_lookup ("%load-path"), 243 | scm_append (scm_list_2 244 | (scm_variable_ref 245 | (scm_c_lookup ("%load-path")), 246 | scm_list_1 (scm_from_locale_string 247 | (SCHEME_DIR))))); 248 | scm_c_primitive_load ((char *) data); 249 | return SCM_UNSPECIFIED; 250 | } 251 | 252 | static void * 253 | init_guile (void *data) 254 | { 255 | /* enables UTF-8 support */ 256 | scm_setlocale (scm_variable_ref (scm_c_lookup ("LC_ALL")), 257 | scm_from_locale_string ("")); 258 | init_gram_types (); 259 | init_gram_hooks (); 260 | scm_c_define_gsubr("terminate", 0, 0, 0, gram_terminate); 261 | return SCM_UNSPECIFIED; 262 | } 263 | 264 | static char * 265 | get_init_file (int argc, char **argv) 266 | { 267 | int opt, len; 268 | char *home = getenv("HOME"), *init_file = calloc(100, sizeof(char)); 269 | if(home) { 270 | strncpy(init_file, home, 100); 271 | strncpy(init_file + strlen(home), "/.gram.d/init.scm", 100 - strlen(home)); 272 | } 273 | while ((opt = getopt (argc, argv, "i:")) != -1) 274 | { 275 | switch (opt) 276 | { 277 | case 'i': 278 | len = strlen (optarg); 279 | free(init_file); 280 | init_file = calloc (len, sizeof (char)); 281 | strncpy (init_file, optarg, len); 282 | break; 283 | } 284 | } 285 | printf("Init file: %s\n", init_file); 286 | return init_file; 287 | } 288 | 289 | void 290 | logger (enum wlc_log_type type, const char *str) 291 | { 292 | printf ("%s\n", str); 293 | } 294 | 295 | int 296 | main (int argc, char **argv) 297 | { 298 | wlc_log_set_handler (logger); 299 | 300 | wlc_set_output_created_cb (output_created); // Done - Untested 301 | wlc_set_output_destroyed_cb (output_destroyed); // Done - Untested 302 | wlc_set_output_focus_cb (output_focus); // Done - Untested 303 | wlc_set_output_resolution_cb (output_resolution); // Done - Untested 304 | wlc_set_output_render_pre_cb (output_render_pre); // Done - Untested 305 | wlc_set_output_render_post_cb (output_render_post); // Done - Untested 306 | wlc_set_view_created_cb (view_created); // Done 307 | wlc_set_view_destroyed_cb (view_destroyed); // Done - Untested 308 | wlc_set_view_focus_cb (view_focus); // Done - Untested 309 | wlc_set_view_move_to_output_cb (view_move_to_output); // Done - Untested 310 | /* punting on these for the moment */ 311 | wlc_set_view_request_geometry_cb (view_request_geometry); 312 | /* wlc_set_state_cb (view_request_state); */ 313 | /* wlc_set_move_cb (view_request_move); */ 314 | /* wlc_set_resize_cb (view_request_resize); */ 315 | wlc_set_view_render_pre_cb (view_render_pre); // Done - Untested 316 | wlc_set_view_render_post_cb (view_render_post); // Done - Untested 317 | wlc_set_keyboard_key_cb (keyboard_key); // Done - should add keyup 318 | /* the pointer_button and pointer_scroll events should be tied into the key 319 | system e.g. (kbd "M-Mouse1") (kbd "M-ScrollUp") */ 320 | wlc_set_pointer_button_cb (pointer_button); 321 | /* wlc_set_pointer_scroll_cb (pointer_scroll); */ 322 | wlc_set_pointer_motion_cb (pointer_motion); // Done - untested 323 | /* this .touch should also be tied into the key system */ 324 | /* wlc_set_touch_touch_cb (touch_touch); */ 325 | wlc_set_compositor_ready_cb (compositor_ready); 326 | wlc_set_compositor_terminate_cb (compositor_terminate); 327 | /* Experimental -- Don't see need for at the moment */ 328 | /* wlc_set_input_created_cb (input_created); */ 329 | /* wlc_set_input_destroyed_cb (input_destroyed); */ 330 | 331 | if (!wlc_init ()) 332 | return EXIT_FAILURE; 333 | 334 | char *init_file = get_init_file (argc, argv); 335 | if (access (init_file, F_OK | R_OK) == -1) 336 | { 337 | init_file = NULL; 338 | } 339 | 340 | scm_with_guile (init_guile, (void *) NULL); 341 | 342 | if (init_file != NULL) 343 | { 344 | scm_with_guile (load_init, init_file); 345 | } 346 | 347 | wlc_run (); 348 | return EXIT_SUCCESS; 349 | } 350 | -------------------------------------------------------------------------------- /test/types/keysym_spec.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | #include 5 | #include 6 | 7 | #include 8 | 9 | #include "../../src/types/keysym.h" 10 | 11 | START_TEST (test_keysym_init) 12 | { 13 | scm_init_guile (); 14 | /* this test depends on internals of guile. do not recommend */ 15 | init_gram_keysym (); 16 | scm_smob_descriptor ssd = scm_smobs[scm_numsmob - 1]; 17 | 18 | ck_assert_str_eq (ssd.name, "keysym"); 19 | } 20 | 21 | END_TEST 22 | START_TEST (test_keysym_to_scm) 23 | { 24 | scm_init_guile (); 25 | init_gram_keysym (); 26 | 27 | struct gram_keysym ks = { 28 | .keycode = XKB_KEY_x, 29 | .sym = XKB_KEY_x, 30 | .mods = { 31 | .leds = 0, 32 | .mods = WLC_BIT_MOD_ALT, 33 | } 34 | }; 35 | 36 | SCM ks_scm = gram_keysym_scm (&ks); 37 | 38 | scm_assert_smob_type (gram_keysym_tag, ks_scm); 39 | 40 | } 41 | 42 | END_TEST 43 | START_TEST (test_keysym_from_scm) 44 | { 45 | scm_init_guile (); 46 | init_gram_keysym (); 47 | 48 | struct gram_keysym ks = { 49 | .keycode = XKB_KEY_x, 50 | .sym = XKB_KEY_x, 51 | .mods = { 52 | .leds = 0, 53 | .mods = WLC_BIT_MOD_ALT, 54 | } 55 | }; 56 | 57 | SCM ks_scm = gram_keysym_scm (&ks); 58 | struct gram_keysym ks2 = *(struct gram_keysym *) SCM_SMOB_DATA (ks_scm); 59 | 60 | ck_assert_uint_eq (ks.keycode, ks2.keycode); 61 | ck_assert_uint_eq (ks.sym, ks2.sym); 62 | ck_assert_uint_eq (ks.mods.mods, ks2.mods.mods); 63 | ck_assert_uint_eq (ks.mods.leds, ks2.mods.leds); 64 | } 65 | 66 | END_TEST 67 | START_TEST (test_keysym_kbd) 68 | { 69 | scm_init_guile (); 70 | init_gram_keysym (); 71 | 72 | scm_c_use_module ("gram keysym"); 73 | 74 | SCM res = scm_call_1 (scm_variable_ref (scm_c_lookup ("kbd")), 75 | scm_from_locale_string ("M-x")); 76 | 77 | scm_assert_smob_type (gram_keysym_tag, res); 78 | struct gram_keysym ks = *(struct gram_keysym *) SCM_SMOB_DATA (res); 79 | 80 | ck_assert_uint_eq (ks.keycode, 0); 81 | ck_assert_uint_eq (ks.sym, XKB_KEY_x); 82 | ck_assert_uint_eq (ks.mods.mods, WLC_BIT_MOD_ALT); 83 | ck_assert_uint_eq (ks.mods.leds, 0); 84 | 85 | res = scm_call_1 (scm_variable_ref (scm_c_lookup ("kbd")), 86 | scm_from_locale_string ("M-.")); 87 | 88 | scm_assert_smob_type (gram_keysym_tag, res); 89 | ks = *(struct gram_keysym *) SCM_SMOB_DATA (res); 90 | 91 | ck_assert_uint_eq (ks.keycode, 0); 92 | ck_assert_uint_eq (ks.sym, XKB_KEY_period); 93 | ck_assert_uint_eq (ks.mods.mods, WLC_BIT_MOD_ALT); 94 | ck_assert_uint_eq (ks.mods.leds, 0); 95 | } 96 | 97 | END_TEST 98 | 99 | START_TEST (test_keysym_kbd_mouse) 100 | { 101 | scm_init_guile(); 102 | init_gram_keysym(); 103 | scm_c_use_module("gram keysym"); 104 | 105 | SCM res = scm_call_1 (scm_variable_ref (scm_c_lookup ("kbd")), 106 | scm_from_locale_string ("M-Mouse2")); 107 | 108 | scm_assert_smob_type (gram_keysym_tag, res); 109 | struct gram_keysym ks = *(struct gram_keysym *) SCM_SMOB_DATA (res); 110 | 111 | ck_assert_uint_eq (ks.keycode, 0); 112 | ck_assert_uint_eq (ks.sym, XKB_KEY_NoSymbol); 113 | ck_assert_uint_eq (ks.mods.mods, WLC_BIT_MOD_ALT); 114 | ck_assert_uint_eq (ks.mods.leds, 0); 115 | ck_assert_uint_eq (ks.mouse, true); 116 | ck_assert_uint_eq (ks.mouse_button, 2); 117 | } 118 | END_TEST 119 | START_TEST (test_keysym_equalp_reflexive) 120 | { 121 | scm_init_guile (); 122 | init_gram_keysym (); 123 | 124 | struct gram_keysym M_x = { 125 | .keycode = XKB_KEY_x, 126 | .sym = XKB_KEY_x, 127 | .mods = { 128 | .leds = 0, 129 | .mods = WLC_BIT_MOD_ALT, 130 | } 131 | }; 132 | 133 | SCM M_x_scm = gram_keysym_scm (&M_x); 134 | SCM M_x_scm2 = gram_keysym_scm (&M_x); 135 | 136 | ck_assert (SCM_BOOL_T == scm_equal_p (M_x_scm, M_x_scm2)); 137 | 138 | struct gram_keysym M_Mouse3 = { 139 | .keycode = 0, 140 | .sym = XKB_KEY_NoSymbol, 141 | .mouse = true, 142 | .mouse_button = 3, 143 | .mods = { 144 | .leds = 0, 145 | .mods = WLC_BIT_MOD_ALT, 146 | } 147 | }; 148 | 149 | SCM M_Mouse3_scm = gram_keysym_scm (&M_Mouse3); 150 | SCM M_Mouse3_scm2 = gram_keysym_scm (&M_Mouse3); 151 | 152 | ck_assert (SCM_BOOL_T == scm_equal_p (M_Mouse3_scm, M_Mouse3_scm2)); 153 | } 154 | 155 | END_TEST 156 | START_TEST (test_keysym_equalp_diff_sym) 157 | { 158 | scm_init_guile (); 159 | init_gram_keysym (); 160 | 161 | struct gram_keysym M_x = { 162 | .keycode = XKB_KEY_x, 163 | .sym = XKB_KEY_x, 164 | .mods = { 165 | .leds = 0, 166 | .mods = WLC_BIT_MOD_ALT, 167 | } 168 | }; 169 | 170 | SCM M_x_scm = gram_keysym_scm (&M_x); 171 | M_x.sym = XKB_KEY_y; 172 | SCM M_x_scm2 = gram_keysym_scm (&M_x); 173 | 174 | ck_assert (SCM_BOOL_F == scm_equal_p (M_x_scm, M_x_scm2)); 175 | } 176 | 177 | END_TEST 178 | START_TEST (test_keysym_equalp_diff_code) 179 | { 180 | scm_init_guile (); 181 | init_gram_keysym (); 182 | 183 | struct gram_keysym M_x = { 184 | .keycode = XKB_KEY_x, 185 | .sym = XKB_KEY_x, 186 | .mods = { 187 | .leds = 0, 188 | .mods = WLC_BIT_MOD_ALT, 189 | } 190 | }; 191 | 192 | SCM M_x_scm = gram_keysym_scm (&M_x); 193 | M_x.keycode = XKB_KEY_y; 194 | SCM M_x_scm2 = gram_keysym_scm (&M_x); 195 | 196 | /* keycode is a book-keeping field that is ignored */ 197 | ck_assert (SCM_BOOL_T == scm_equal_p (M_x_scm, M_x_scm2)); 198 | } 199 | 200 | END_TEST 201 | START_TEST (test_keysym_equalp_diff_mods) 202 | { 203 | scm_init_guile (); 204 | init_gram_keysym (); 205 | 206 | struct gram_keysym M_x = { 207 | .keycode = XKB_KEY_x, 208 | .sym = XKB_KEY_x, 209 | .mods = { 210 | .leds = 0, 211 | .mods = WLC_BIT_MOD_ALT, 212 | } 213 | }; 214 | 215 | SCM M_x_scm = gram_keysym_scm (&M_x); 216 | M_x.mods.mods |= WLC_BIT_MOD_CTRL; 217 | SCM M_x_scm2 = gram_keysym_scm (&M_x); 218 | 219 | ck_assert (SCM_BOOL_F == scm_equal_p (M_x_scm, M_x_scm2)); 220 | } 221 | 222 | END_TEST 223 | START_TEST (test_keysym_equalp_diff_leds) 224 | { 225 | scm_init_guile (); 226 | init_gram_keysym (); 227 | 228 | struct gram_keysym M_x = { 229 | .keycode = XKB_KEY_x, 230 | .sym = XKB_KEY_x, 231 | .mods = { 232 | .leds = 0, 233 | .mods = WLC_BIT_MOD_ALT, 234 | } 235 | }; 236 | 237 | SCM M_x_scm = gram_keysym_scm (&M_x); 238 | M_x.mods.leds = 1; 239 | SCM M_x_scm2 = gram_keysym_scm (&M_x); 240 | 241 | /* LEDs are currently ignored as they have no representation in 242 | Guile */ 243 | ck_assert (SCM_BOOL_T == scm_equal_p (M_x_scm, M_x_scm2)); 244 | } 245 | 246 | END_TEST 247 | START_TEST (test_keysym_equalp_mouse) 248 | { 249 | scm_init_guile (); 250 | init_gram_keysym (); 251 | 252 | struct gram_keysym M_x = { 253 | .keycode = XKB_KEY_x, 254 | .sym = XKB_KEY_x, 255 | .mouse = false, 256 | .mods = { 257 | .leds = 0, 258 | .mods = WLC_BIT_MOD_ALT, 259 | } 260 | }; 261 | 262 | struct gram_keysym M_Mouse3 = { 263 | .keycode = 0, 264 | .sym = XKB_KEY_NoSymbol, 265 | .mouse = true, 266 | .mouse_button = 3, 267 | .mods = { 268 | .leds = 0, 269 | .mods = WLC_BIT_MOD_ALT, 270 | } 271 | }; 272 | 273 | SCM M_x_scm = gram_keysym_scm (&M_x); 274 | SCM M_Mouse3_scm = gram_keysym_scm (&M_Mouse3); 275 | 276 | ck_assert (SCM_BOOL_F == scm_equal_p (M_x_scm, M_Mouse3_scm)); 277 | } 278 | 279 | END_TEST 280 | START_TEST (test_keysym_display) 281 | { 282 | scm_init_guile (); 283 | scm_setlocale (scm_variable_ref (scm_c_lookup ("LC_ALL")), 284 | scm_from_locale_string ("")); 285 | init_gram_keysym (); 286 | 287 | struct gram_keysym M_x = { 288 | .keycode = XKB_KEY_x, 289 | .sym = XKB_KEY_x, 290 | .mouse = false, 291 | .mods = { 292 | .leds = 0, 293 | .mods = WLC_BIT_MOD_ALT, 294 | } 295 | }; 296 | 297 | struct gram_keysym M_Mouse3 = { 298 | .keycode = XKB_KEY_NoSymbol, 299 | .sym = XKB_KEY_NoSymbol, 300 | .mods = { 301 | .leds = 0, 302 | .mods = WLC_BIT_MOD_ALT, 303 | }, 304 | .mouse = true, 305 | .mouse_button = 3 306 | }; 307 | 308 | SCM M_x_scm = gram_keysym_scm (&M_x); 309 | SCM M_Mouse3_scm = gram_keysym_scm(&M_Mouse3); 310 | SCM port = scm_open_output_string (); 311 | scm_display (M_x_scm, port); 312 | 313 | ck_assert_str_eq (scm_to_locale_string (scm_get_output_string (port)), 314 | "#"); 315 | scm_close (port); 316 | 317 | M_x.mods.mods |= WLC_BIT_MOD_LOGO | WLC_BIT_MOD_CTRL; 318 | M_x_scm = gram_keysym_scm (&M_x); 319 | port = scm_open_output_string (); 320 | 321 | scm_display (M_x_scm, port); 322 | ck_assert_str_eq (scm_to_locale_string (scm_get_output_string (port)), 323 | "#"); 324 | scm_close (port); 325 | 326 | M_x.sym = XKB_KEY_BackSpace; 327 | M_x.mods.mods = 0; 328 | M_x_scm = gram_keysym_scm (&M_x); 329 | port = scm_open_output_string (); 330 | 331 | scm_display (M_x_scm, port); 332 | ck_assert_str_eq (scm_to_locale_string (scm_get_output_string (port)), 333 | "#"); 334 | scm_close (port); 335 | 336 | port = scm_open_output_string (); 337 | scm_display(M_Mouse3_scm, port); 338 | ck_assert_str_eq(scm_to_locale_string (scm_get_output_string (port)), 339 | "#"); 340 | scm_close (port); 341 | } 342 | 343 | END_TEST 344 | START_TEST (test_keysym_display_unicode) 345 | { 346 | scm_init_guile (); 347 | scm_setlocale (scm_variable_ref (scm_c_lookup ("LC_ALL")), 348 | scm_from_locale_string ("")); 349 | init_gram_keysym (); 350 | 351 | struct gram_keysym M_x = { 352 | .keycode = XKB_KEY_x, 353 | .sym = XKB_KEY_udiaeresis, 354 | .mods = { 355 | .leds = 0, 356 | .mods = 0, 357 | } 358 | }; 359 | 360 | SCM M_x_scm = gram_keysym_scm (&M_x); 361 | SCM port = scm_open_output_string (); 362 | 363 | scm_display (M_x_scm, port); 364 | ck_assert_str_eq (scm_to_utf8_string (scm_get_output_string (port)), 365 | "#"); 366 | scm_close (port); 367 | 368 | M_x.sym = XKB_KEY_emacron; 369 | M_x_scm = gram_keysym_scm (&M_x); 370 | port = scm_open_output_string (); 371 | 372 | scm_display (M_x_scm, port); 373 | ck_assert_str_eq (scm_to_utf8_string (scm_get_output_string (port)), 374 | "#"); 375 | scm_close (port); 376 | 377 | /* notify when we have pile of poo support */ 378 | ck_assert_uint_eq (0, 379 | xkb_keysym_from_name ("💩", 380 | XKB_KEYSYM_CASE_INSENSITIVE)); 381 | } 382 | 383 | END_TEST 384 | START_TEST (test_keysym_swallow) 385 | { 386 | scm_init_guile (); 387 | init_gram_keysym (); 388 | 389 | ck_assert (!gram_swallow); 390 | 391 | scm_c_use_module ("gram keysym"); 392 | 393 | SCM res = scm_call_0 (scm_variable_ref (scm_c_lookup ("swallow-next-key"))); 394 | 395 | ck_assert (gram_swallow); 396 | ck_assert_ptr_eq (res, SCM_BOOL_T); 397 | } 398 | 399 | END_TEST 400 | 401 | START_TEST (test_keysym_unmodified) 402 | { 403 | scm_init_guile (); 404 | init_gram_keysym (); 405 | 406 | scm_c_use_module ("gram keysym"); 407 | 408 | struct gram_keysym ks = { 409 | .keycode = XKB_KEY_x, 410 | .sym = XKB_KEY_x, 411 | .mods = { 412 | .leds = 0, 413 | .mods = WLC_BIT_MOD_ALT, 414 | }, 415 | .mouse = false, 416 | .mouse_button = -1 417 | }; 418 | 419 | SCM res = scm_call_1 (scm_variable_ref (scm_c_lookup ("unmodified")), 420 | gram_keysym_scm(&ks)); 421 | 422 | scm_assert_smob_type(gram_keysym_tag, res); 423 | struct gram_keysym *unmod = (struct gram_keysym*) SCM_SMOB_DATA(res); 424 | /* it should reset mods */ 425 | ck_assert_uint_eq(unmod->mods.mods, 0); 426 | /* it shouldn't change anything else */ 427 | ck_assert_uint_eq(unmod->mods.leds, ks.mods.leds); 428 | ck_assert_uint_eq(unmod->sym, ks.sym); 429 | ck_assert_uint_eq(unmod->keycode, ks.keycode); 430 | ck_assert_uint_eq(unmod->mouse, ks.mouse); 431 | ck_assert_uint_eq(unmod->mouse_button, ks.mouse_button); 432 | } 433 | END_TEST 434 | 435 | Suite * 436 | 437 | keysym_suite (void) 438 | { 439 | Suite *s; 440 | TCase *tc_core, *tc_convert, *tc_equalp, *tc_display, *tc_swallow, *tc_unmod; 441 | 442 | s = suite_create ("types/keysym"); 443 | 444 | tc_core = tcase_create ("Init"); 445 | tcase_add_test (tc_core, test_keysym_init); 446 | suite_add_tcase (s, tc_core); 447 | 448 | tc_convert = tcase_create ("Convert"); 449 | tcase_add_test (tc_convert, test_keysym_to_scm); 450 | tcase_add_test (tc_convert, test_keysym_from_scm); 451 | tcase_add_test (tc_convert, test_keysym_kbd); 452 | tcase_add_test (tc_convert, test_keysym_kbd_mouse); 453 | suite_add_tcase (s, tc_convert); 454 | 455 | /* testing permutations of these is left as an exercise for the 456 | reader */ 457 | tc_equalp = tcase_create ("equalp"); 458 | tcase_add_test (tc_equalp, test_keysym_equalp_reflexive); 459 | tcase_add_test (tc_equalp, test_keysym_equalp_diff_sym); 460 | tcase_add_test (tc_equalp, test_keysym_equalp_diff_code); 461 | tcase_add_test (tc_equalp, test_keysym_equalp_diff_mods); 462 | tcase_add_test (tc_equalp, test_keysym_equalp_diff_leds); 463 | tcase_add_test (tc_equalp, test_keysym_equalp_mouse); 464 | suite_add_tcase (s, tc_equalp); 465 | 466 | tc_display = tcase_create ("display"); 467 | tcase_add_test (tc_display, test_keysym_display); 468 | tcase_add_test (tc_display, test_keysym_display_unicode); 469 | suite_add_tcase (s, tc_display); 470 | 471 | tc_swallow = tcase_create ("swallow"); 472 | tcase_add_test (tc_swallow, test_keysym_swallow); 473 | suite_add_tcase (s, tc_swallow); 474 | 475 | tc_unmod = tcase_create("unmodified"); 476 | tcase_add_test (tc_unmod, test_keysym_unmodified); 477 | suite_add_tcase (s, tc_unmod); 478 | 479 | return s; 480 | } 481 | 482 | int 483 | main (void) 484 | { 485 | int num_fail; 486 | Suite *s; 487 | SRunner *sr; 488 | 489 | s = keysym_suite (); 490 | sr = srunner_create (s); 491 | 492 | srunner_set_tap (sr, "-"); 493 | srunner_run_all (sr, CK_NORMAL); 494 | num_fail = srunner_ntests_failed (sr); 495 | srunner_free (sr); 496 | return (num_fail == 0) ? EXIT_SUCCESS : EXIT_FAILURE; 497 | } 498 | -------------------------------------------------------------------------------- /src/types/view.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "view.h" 5 | #include "output.h" 6 | 7 | static struct gram_view *view_table[GRAM_MAX_VIEWS]; 8 | static SCM smob_table[GRAM_MAX_VIEWS]; 9 | 10 | static int 11 | gram_view_print (SCM view_smob, SCM port, scm_print_state * pstate) 12 | { 13 | scm_assert_smob_type (gram_view_tag, view_smob); 14 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (view_smob); 15 | if (view->active) 16 | { 17 | const char *title = wlc_view_get_title (view->view); 18 | scm_puts ("#", port); 21 | 22 | return 1; 23 | } 24 | return 0; 25 | } 26 | 27 | SCM 28 | gram_view_scm (const wlc_handle view) 29 | { 30 | uint32_t i; 31 | for (i = 0; i < GRAM_MAX_VIEWS; i++) 32 | { 33 | if (view_table[i] && view_table[i]->view == view) 34 | { 35 | break; 36 | } 37 | } 38 | 39 | /* view not in table */ 40 | if (i >= GRAM_MAX_VIEWS) 41 | { 42 | for (i = 0; i < GRAM_MAX_VIEWS; i++) 43 | { 44 | if (view_table[i] == NULL) 45 | { 46 | view_table[i] = (struct gram_view *) 47 | scm_gc_malloc (sizeof (struct gram_view), "view"); 48 | *(wlc_handle *) & view_table[i]->view = view; 49 | smob_table[i] = scm_new_smob (gram_view_tag, 50 | (scm_t_bits) view_table[i]); 51 | break; 52 | } 53 | } 54 | } 55 | 56 | if (i >= GRAM_MAX_VIEWS) 57 | { 58 | /* still no room */ 59 | return SCM_BOOL_F; 60 | } 61 | view_table[i]->active = true; 62 | return smob_table[i]; 63 | } 64 | 65 | SCM 66 | gram_view_viewp (SCM maybe_view) 67 | { 68 | if (SCM_SMOB_PREDICATE (gram_view_tag, maybe_view)) 69 | { 70 | return SCM_BOOL_T; 71 | } 72 | return SCM_BOOL_F; 73 | } 74 | 75 | SCM 76 | gram_view_activep (SCM _view) 77 | { 78 | if (SCM_SMOB_PREDICATE (gram_view_tag, _view)) 79 | { 80 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 81 | return view->active ? SCM_BOOL_T : SCM_BOOL_F; 82 | } 83 | return SCM_BOOL_F; 84 | } 85 | 86 | void 87 | gram_view_deactivate (const wlc_handle view) 88 | { 89 | uint32_t i; 90 | for (i = 0; i < GRAM_MAX_VIEWS; i++) 91 | { 92 | if (view_table[i] && view_table[i]->view == view) 93 | { 94 | printf ("View %d deactivated\n", i); 95 | view_table[i]->active = false; 96 | } 97 | } 98 | } 99 | 100 | static size_t 101 | gram_view_free (SCM _view) 102 | { 103 | uint32_t i; 104 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 105 | for (i = 0; i < GRAM_MAX_VIEWS; i++) 106 | { 107 | if (view_table[i] == view) 108 | { 109 | view_table[i] = NULL; 110 | smob_table[i] = NULL; 111 | } 112 | } 113 | 114 | scm_gc_free (view, sizeof (struct gram_view), "view"); 115 | return 0; 116 | } 117 | 118 | 119 | static SCM 120 | gram_view_close (SCM _view) 121 | { 122 | scm_assert_smob_type (gram_view_tag, _view); 123 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 124 | if (view->active) 125 | { 126 | wlc_view_close (view->view); 127 | } 128 | 129 | view->active = false; 130 | return SCM_BOOL_T; 131 | } 132 | 133 | static SCM 134 | gram_view_bring_to_front (SCM _view) 135 | { 136 | scm_assert_smob_type (gram_view_tag, _view); 137 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 138 | if (view->active) 139 | { 140 | wlc_view_bring_to_front (view->view); 141 | } 142 | return _view; 143 | } 144 | 145 | static SCM 146 | gram_view_send_to_back (SCM _view) 147 | { 148 | scm_assert_smob_type (gram_view_tag, _view); 149 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 150 | if (view->active) 151 | { 152 | wlc_view_send_to_back (view->view); 153 | } 154 | return _view; 155 | } 156 | 157 | static SCM 158 | gram_view_focus (SCM _view) 159 | { 160 | scm_assert_smob_type (gram_view_tag, _view); 161 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 162 | if (view->active) 163 | { 164 | wlc_view_focus (view->view); 165 | } 166 | return _view; 167 | } 168 | 169 | SCM 170 | gram_geometry_scm (const struct wlc_geometry * geo) 171 | { 172 | /* can't make records from c and a new smob for this is really overkill */ 173 | return scm_cons (scm_cons (scm_from_int32 (geo->origin.x), 174 | scm_from_int32 (geo->origin.y)), 175 | scm_cons (scm_from_int32 (geo->size.w), 176 | scm_from_int32 (geo->size.h))); 177 | } 178 | 179 | /* converts an SCM to a wlc_geometry. Assumes input is valid. */ 180 | static const struct wlc_geometry 181 | gram_geometry_from_scm (SCM _geo) 182 | { 183 | struct wlc_geometry geo = { 184 | {scm_to_int32 (scm_caar (_geo)), 185 | scm_to_int32 (scm_cdar (_geo))}, 186 | {scm_to_int32 (scm_cadr (_geo)), 187 | scm_to_int32 (scm_cddr (_geo))} 188 | }; 189 | 190 | return geo; 191 | } 192 | 193 | static SCM 194 | gram_view_get_geometry (SCM _view) 195 | { 196 | scm_assert_smob_type (gram_view_tag, _view); 197 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 198 | if (view->active) 199 | { 200 | return gram_geometry_scm (wlc_view_get_geometry (view->view)); 201 | } 202 | return SCM_BOOL_F; 203 | } 204 | 205 | static SCM 206 | gram_view_set_geometry (SCM _view, SCM _geo) 207 | { 208 | scm_assert_smob_type (gram_view_tag, _view); 209 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 210 | if (view->active) 211 | { 212 | if (scm_pair_p (_geo) == SCM_BOOL_T && scm_pair_p (scm_car (_geo)) == SCM_BOOL_T 213 | && scm_pair_p (scm_cdr (_geo)) == SCM_BOOL_T) 214 | { 215 | const struct wlc_geometry geo = gram_geometry_from_scm (_geo); 216 | const struct wlc_geometry curr = *wlc_view_get_geometry (view->view); 217 | if (curr.origin.x == geo.origin.x && 218 | curr.origin.y == geo.origin.y && 219 | curr.size.w == geo.size.w && curr.size.h == geo.size.h) 220 | { 221 | /* no change, do nothing */ 222 | return _view; 223 | } 224 | wlc_view_set_geometry (view->view, 0, &geo); 225 | /* printf ("Set %s to (%d, %d)\n", wlc_view_get_title (view->view), */ 226 | /* geo.size.w, geo.size.h); */ 227 | return _view; 228 | } 229 | } 230 | return SCM_BOOL_F; 231 | } 232 | 233 | static SCM 234 | gram_view_state_scm (uint32_t state) 235 | { 236 | SCM state_list = SCM_EOL; 237 | if (state & WLC_BIT_ACTIVATED) { 238 | state_list = scm_cons(scm_from_locale_symbol ("activated"), state_list); 239 | } 240 | if (state & WLC_BIT_FULLSCREEN) { 241 | state_list = scm_cons(scm_from_locale_symbol ("fullscreen"), state_list); 242 | } 243 | if (state & WLC_BIT_MAXIMIZED) { 244 | state_list = scm_cons(scm_from_locale_symbol ("maximized"), state_list); 245 | } 246 | if (state & WLC_BIT_MOVING) { 247 | state_list = scm_cons(scm_from_locale_symbol ("moving"), state_list); 248 | } 249 | if (state & WLC_BIT_RESIZING) { 250 | state_list = scm_cons(scm_from_locale_symbol ("resizing"), state_list); 251 | } 252 | 253 | return state_list; 254 | } 255 | 256 | static uint32_t 257 | gram_view_state_from_scm (SCM _state) 258 | { 259 | uint32_t state = 0; 260 | if(scm_list_p(_state) == SCM_BOOL_F) { 261 | return state; 262 | } 263 | 264 | SCM lst = _state; 265 | while(scm_null_p(lst) == SCM_BOOL_F) { 266 | SCM car = scm_car(lst); 267 | if (scm_eq_p (scm_from_locale_symbol ("activated"), car) == SCM_BOOL_T) 268 | { 269 | state |= WLC_BIT_ACTIVATED; 270 | } 271 | if (scm_eq_p (scm_from_locale_symbol ("fullscreen"), car) == SCM_BOOL_T) 272 | { 273 | state |= WLC_BIT_FULLSCREEN; 274 | } 275 | if (scm_eq_p (scm_from_locale_symbol ("maximized"), car) == SCM_BOOL_T) 276 | { 277 | state |= WLC_BIT_MAXIMIZED; 278 | } 279 | if (scm_eq_p (scm_from_locale_symbol ("moving"), car) == SCM_BOOL_T) 280 | { 281 | state |= WLC_BIT_MOVING; 282 | } 283 | if (scm_eq_p (scm_from_locale_symbol ("resizing"), car) == SCM_BOOL_T) 284 | { 285 | state |= WLC_BIT_RESIZING; 286 | } 287 | 288 | lst = scm_cdr(lst); 289 | } 290 | return state; 291 | } 292 | 293 | static SCM 294 | gram_view_get_state (SCM _view) 295 | { 296 | scm_assert_smob_type (gram_view_tag, _view); 297 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 298 | if (view->active) 299 | { 300 | return gram_view_state_scm (wlc_view_get_state (view->view)); 301 | } 302 | return SCM_BOOL_F; 303 | } 304 | 305 | 306 | static SCM 307 | gram_view_set_state (SCM _view, SCM _state) 308 | { 309 | scm_assert_smob_type (gram_view_tag, _view); 310 | 311 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 312 | if (view->active) 313 | { 314 | /* should probably rewrite this to set state in the `from` 315 | * function, but idk. Not sure what the repercussions of always 316 | * setting every state are. */ 317 | uint32_t state = gram_view_state_from_scm (_state); 318 | for(int i = 0; i < 5; i++) { 319 | wlc_view_set_state(view->view, 1 << i, !((state & (1 << i)) == 0)); 320 | } 321 | return _view; 322 | } 323 | return SCM_BOOL_F; 324 | } 325 | 326 | /* not sure what this is supposed to be interpreted as; punting */ 327 | /* static SCM */ 328 | /* gram_view_get_mask (SCM _view) */ 329 | /* { */ 330 | /* struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); */ 331 | /* if (view->active) */ 332 | /* { */ 333 | /* return gram_view_mask_scm(wlc_view_get_mask (view->view)); */ 334 | /* } */ 335 | /* return SCM_BOOL_F; */ 336 | /* } */ 337 | 338 | static SCM 339 | gram_view_get_parent (SCM _view) 340 | { 341 | scm_assert_smob_type (gram_view_tag, _view); 342 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 343 | if (view->active) 344 | { 345 | return gram_view_scm (wlc_view_get_parent (view->view)); 346 | } 347 | return SCM_BOOL_F; 348 | } 349 | 350 | static SCM 351 | gram_view_set_parent (SCM _view, SCM _parent) 352 | { 353 | scm_assert_smob_type (gram_view_tag, _view); 354 | scm_assert_smob_type (gram_view_tag, _parent); 355 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 356 | struct gram_view *parent = (struct gram_view *) SCM_SMOB_DATA (_parent); 357 | 358 | if (view->active && parent->active) 359 | { 360 | wlc_view_set_parent (view->view, parent->view); 361 | return SCM_ELISP_NIL; 362 | } 363 | return SCM_BOOL_F; 364 | } 365 | 366 | static SCM 367 | gram_view_get_output (SCM _view) 368 | { 369 | scm_assert_smob_type (gram_view_tag, _view); 370 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 371 | if (view->active) 372 | { 373 | const wlc_handle out = wlc_view_get_output (view->view); 374 | SCM out_smob = gram_output_scm (out); 375 | return out_smob; 376 | } 377 | printf ("Inactive view accessed: %lu\n", view->view); 378 | return SCM_BOOL_F; 379 | } 380 | 381 | static SCM 382 | gram_view_set_output (SCM _view, SCM _output) 383 | { 384 | scm_assert_smob_type (gram_view_tag, _view); 385 | scm_assert_smob_type (gram_output_tag, _output); 386 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 387 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 388 | 389 | if (view->active && output->active) 390 | { 391 | wlc_view_set_output (view->view, output->output); 392 | /* printf ("Set output of %s\n", wlc_view_get_title (view->view)); */ 393 | return SCM_BOOL_T; 394 | } 395 | return SCM_BOOL_F; 396 | } 397 | 398 | static SCM 399 | gram_view_get_app_id (SCM _view) 400 | { 401 | scm_assert_smob_type (gram_view_tag, _view); 402 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 403 | if (view->active) 404 | { 405 | const char *app_id = wlc_view_get_app_id (view->view); 406 | if (app_id) 407 | { 408 | return scm_from_locale_string (app_id); 409 | } 410 | else 411 | { 412 | return scm_from_locale_string (""); 413 | } 414 | } 415 | return SCM_BOOL_F; 416 | } 417 | 418 | static SCM 419 | gram_view_get_class (SCM _view) 420 | { 421 | scm_assert_smob_type (gram_view_tag, _view); 422 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 423 | if (view->active) 424 | { 425 | const char *class = wlc_view_get_class (view->view); 426 | if (class != NULL) 427 | { 428 | return scm_from_locale_string (class); 429 | } 430 | else 431 | { 432 | return scm_from_locale_string (""); 433 | } 434 | } 435 | return SCM_BOOL_F; 436 | } 437 | 438 | static SCM 439 | gram_view_get_title (SCM _view) 440 | { 441 | scm_assert_smob_type (gram_view_tag, _view); 442 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 443 | if (view->active) 444 | { 445 | const char *title = wlc_view_get_title (view->view); 446 | if (title != NULL) 447 | { 448 | return scm_from_locale_string (title); 449 | } 450 | else 451 | { 452 | return scm_from_locale_string (""); 453 | } 454 | } 455 | return SCM_BOOL_F; 456 | } 457 | 458 | static SCM 459 | gram_view_type_scm (uint32_t type) 460 | { 461 | SCM types = SCM_EOL; 462 | if (type & WLC_BIT_MODAL) 463 | { 464 | types = scm_cons (scm_from_locale_symbol ("modal"), types); 465 | } 466 | 467 | if (type & WLC_BIT_OVERRIDE_REDIRECT) 468 | { 469 | types = scm_cons (scm_from_locale_symbol ("override-redirect"), types); 470 | } 471 | 472 | if (type & WLC_BIT_POPUP) 473 | { 474 | types = scm_cons (scm_from_locale_symbol ("popup"), types); 475 | } 476 | 477 | if (type & WLC_BIT_SPLASH) 478 | { 479 | types = scm_cons (scm_from_locale_symbol ("splash"), types); 480 | } 481 | 482 | if (type & WLC_BIT_UNMANAGED) 483 | { 484 | types = scm_cons (scm_from_locale_symbol ("unmanaged"), types); 485 | } 486 | 487 | return types; 488 | } 489 | 490 | static SCM 491 | gram_view_get_types (SCM _view) 492 | { 493 | scm_assert_smob_type (gram_view_tag, _view); 494 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 495 | if (view->active) 496 | { 497 | return gram_view_type_scm (wlc_view_get_type (view->view)); 498 | } 499 | return SCM_BOOL_F; 500 | } 501 | 502 | static SCM 503 | gram_view_show (SCM _view, SCM _output) 504 | { 505 | scm_assert_smob_type (gram_view_tag, _view); 506 | scm_assert_smob_type (gram_output_tag, _output); 507 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 508 | struct gram_output *output = (struct gram_output *) SCM_SMOB_DATA (_output); 509 | if (view->active && output->active) 510 | { 511 | wlc_view_set_mask (view->view, 512 | wlc_output_get_mask (wlc_view_get_output 513 | (view->view))); 514 | return _view; 515 | } 516 | return SCM_BOOL_F; 517 | } 518 | 519 | static SCM 520 | gram_view_hide (SCM _view) 521 | { 522 | scm_assert_smob_type (gram_view_tag, _view); 523 | struct gram_view *view = (struct gram_view *) SCM_SMOB_DATA (_view); 524 | if (view->active) 525 | { 526 | wlc_view_set_mask (view->view, 0); 527 | return _view; 528 | } 529 | return SCM_BOOL_F; 530 | } 531 | 532 | static void 533 | init_gram_view_methods (void *data) 534 | { 535 | scm_c_define_gsubr ("close", 1, 0, 0, gram_view_close); 536 | scm_c_define_gsubr ("bring-to-front", 1, 0, 0, gram_view_bring_to_front); 537 | scm_c_define_gsubr ("send-to-back", 1, 0, 0, gram_view_send_to_back); 538 | scm_c_define_gsubr ("focus", 1, 0, 0, gram_view_focus); 539 | scm_c_define_gsubr ("get-geometry", 1, 0, 0, gram_view_get_geometry); 540 | scm_c_define_gsubr ("set-geometry", 2, 0, 0, gram_view_set_geometry); 541 | scm_c_define_gsubr ("get-state", 1, 0, 0, gram_view_get_state); 542 | scm_c_define_gsubr ("set-state", 2, 0, 0, gram_view_set_state); 543 | /* scm_c_define_gsubr ("get-mask", 1, 0, 0, gram_view_get_mask); */ 544 | scm_c_define_gsubr ("get-parent", 1, 0, 0, gram_view_get_parent); 545 | scm_c_define_gsubr ("set-parent", 2, 0, 0, gram_view_set_parent); 546 | scm_c_define_gsubr ("get-output", 1, 0, 0, gram_view_get_output); 547 | scm_c_define_gsubr ("set-output", 2, 0, 0, gram_view_set_output); 548 | scm_c_define_gsubr ("get-app-id", 1, 0, 0, gram_view_get_app_id); 549 | scm_c_define_gsubr ("get-class", 1, 0, 0, gram_view_get_class); 550 | scm_c_define_gsubr ("get-title", 1, 0, 0, gram_view_get_title); 551 | scm_c_define_gsubr ("get-types", 1, 0, 0, gram_view_get_types); 552 | scm_c_define_gsubr ("view?", 1, 0, 0, gram_view_viewp); 553 | scm_c_define_gsubr ("active?", 1, 0, 0, gram_view_activep); 554 | scm_c_define_gsubr ("hide", 1, 0, 0, gram_view_hide); 555 | scm_c_define_gsubr ("show", 2, 0, 0, gram_view_show); 556 | 557 | scm_c_export ("close", "bring-to-front", "send-to-back", "focus", 558 | "get-geometry", "set-geometry", 559 | "get-state", "set-state", 560 | "get-parent", "set-parent", 561 | "get-output", "set-output", 562 | "get-app-id", "get-class", "get-title", 563 | "get-types", "view?", "active?", "hide", "show", NULL); 564 | } 565 | 566 | void 567 | init_gram_view (void) 568 | { 569 | for (uint32_t i = 0; i < GRAM_MAX_VIEWS; i++) 570 | { 571 | view_table[i] = NULL; 572 | smob_table[i] = NULL; 573 | } 574 | 575 | gram_view_tag = scm_make_smob_type ("view", sizeof (struct gram_view)); 576 | scm_set_smob_print (gram_view_tag, gram_view_print); 577 | scm_set_smob_free (gram_view_tag, gram_view_free); 578 | 579 | scm_c_define_module ("gram view", init_gram_view_methods, NULL); 580 | } 581 | --------------------------------------------------------------------------------