init commit

README.org

@@ -0,0 +1,127 @@
+#+title: Readme
+#+STARTUP: inlineimages
+#+OPTIONS: toc:3 ^:nil
+
+** SWAYIPC
+
+I am an =Emacs= user and previously used =StumpWM=, an =X11= window manager written in =Common Lisp=. I believe window managers should be scriptable because the level of workflow customization required by users often exceeds what can be achieved with simple configuration parameters (see my workflow below for a clearer understanding of why this is the case). Unfortunately, =Sway/i3= lacks a straightforward programmable interface for customization. This project provides complete control over =Sway/i3= using =Guile=! 
+
+** Why Sway?
+
+I had to migrate to =Wayland= at some point. Being a big fan of =StumpWM=, I tried to replicate a similar environment in one of the =Wayland= window managers. I made some progress with =hyprland= using a set of =Guile= bindings I developed called =hypripc=, but I found that =Hyprland= isn't as stable as =Sway=.
+
+** Quick Overview
+
+*** Query Sway
+
+You can retrieve information about =Sway=, such as list of available =workspaces= or =outputs=. The response will be in Guile records, which you can easily manipulate! (refer to =swayipc/records.scm=)
+
+#+begin_src scheme 
+;; get focused workspace from a list of workspaces
+(define (focused-workspace-name workspaces)
+  (cond
+    ((null? workspaces) #f)
+    ((equal? #t (sway-workspace-focused (car workspaces)))
+    (sway-workspace-name (car workspaces)))
+    (else (focused-workspace-name (cdr workspaces)))))
+
+(focused-workspace-name (sway-get-workspaces))
+#+end_src
+
+*** Assign Keybindings
+
+You can assign keybindings that execute Guile code! Obviously, running shell commands is straightforward since you're operating within Guile. Additionally, you have full access to Sway/i3 specific commands (refer to =swayipc/dispatcher.scm=).
+
+#+begin_src scheme 
+  ;; define leader keymap
+  (sway-define-keys
+   #:prefix "s-Space" #:wk "Leader"
+   `("o" (exec "rofi -show drun"))
+   `("C-g" (sway-mode "default") #:wk "abort")
+
+   ;; rofi keymap
+   `(sway-define-keys
+     #:prefix "r" #:wk "Rofi"
+     ("p" (exec "~/.config/rofi/bin/password-manager"))
+     ("m" (exec "rofi-mount"))
+     ("u" (exec "rofi-unmount"))
+     ("w" (exec ".config/rofi/bin/wifi"))
+     ("b" (exec "~/.config/rofi/bin/bluetooth"))
+     ("f" (exec "~/.config/rofi/bin/finder"))
+     ("k" (exec "~/.config/rofi/bin/keyboard-layout"))
+     ("P" (exec "~/.config/rofi/bin/powermenu"))
+     ("s" (exec "~/.config/rofi/bin/sound-input"))
+     ("S" (exec "~/.config/rofi/bin/sound-output")))
+
+   ;; window management
+   `(sway-define-keys
+     #:prefix "w" #:wk "Window"
+     ("v" (sway-split-container SWAY-SPLIT-VERTICAL))
+     ("h" (sway-split-container SWAY-SPLIT-HORIZONTAL))
+     ("f" (sway-fullscreen SWAY-FULLSCREEN-TOGGLE))
+     ("d" (sway-fullscreen SWAY-FULLSCREEN-TOGGLE))))
+#+end_src
+
+*** Subscribe for Events
+
+Certain scenarios necessitate subscribing to events. One example from my =workflow= described below requires this capability. With =swayipc=, you have the ability to listen for events and execute actions in response.
+
+#+begin_src scheme 
+  (define (workspace-changed workspace-event)
+    (let* ((current-tree (sway-workspace-event-current workspace-event))
+           (workspace (sway-tree-name current-tree))
+           (focused-workspace (focused-workspace (sway-get-workspaces))))
+
+      (display workspace)))
+
+    (add-hook! sway-workspace-hook workspace-changed)
+#+end_src
+
+** Documentation (WIP)
+
+Most of the source code is documented. You can refer to =init.scm= for a configuration sample. Here are some important points to consider before hacking your Sway setup:
+
+*** Quick Start
+Clone this repository to your =~/.config/sway=
+
+*** Project Structure
+
+| File                         | Description                                                                                               |
+|------------------------------+-----------------------------------------------------------------------------------------------------------|
+| init.scm                     | Main entry point for configuring Sway using Guile.                                                        |
+| behavior.scm                 | Loaded by =init.scm=; modifies parameters and behavior of Sway.                                             |
+| keybindings.scm              | Loaded by =init.scm=; adds custom keybindings to Sway.                                                      |
+| commander                    | Guile script to send commands to =swayipc= (facilitates keybinding functionality).                          |
+| config                       | Sway configuration file; typically used to invoke =init.scm=.                                               |
+| sjson                        | A patched version of =guile-json=; planned to be a separate dependency in the future (not embedded).        |
+|------------------------------+-----------------------------------------------------------------------------------------------------------|
+| modules/                     | Directory containing modules for extending Sway using =swayipc=.                                            |
+| modules/auto-reload.scm      | TODO: Watcher to automatically reload Sway when Guile files change.                                       |
+| modules/general.scm          | Inspired by Emacs =general= package; provides an easy interface for assigning keybindings.                  |
+| modules/kbd.scm              | WIP: Translates Emacs-like keybindings to be compatible with =Sway=.                                        |
+| modules/which-key.scm        | TODO: Inspired by Emacs =which-key= package; enhances keybinding discovery and management.                  |
+| modules/workspace-grid.scm   | Configures workspaces in a grid and enables movement between them in specified directions (see workflow). |
+| modules/workspace-groups.scm | WIP: Spans/synchronizes workspaces across monitors (see workflow).                                        |
+|------------------------------+-----------------------------------------------------------------------------------------------------------|
+| swayipc/                     | Directory containing the core code for =swayipc=, facilitating communication with Sway.                     |
+| swayipc/connection           | Establishes =IPC= connection for handling events and commands with Sway.                                    |
+| swayipc/dispatcher           | Provides =Guile functions= for all available =Sway= commands.                                                 |
+| swayipc/events               | Provides =Gulie Hooks= for all available =Sway= events.                                                       |
+| swayipc/info                 | Provides =Guile functions= for querying Sway's current state and information.                               |
+| swayipc/records              | Provides =Guile records= representing Sway's data structures.                                               |
+
+1- You can start your =swayipc= configurations from the =REPL=, =terminal=, or a configuration file.
+Remember: for debugging or displaying output, it's best to run Guile from the REPL or terminal. You can also pipe the output to a file if you desire.
+
+#+begin_src conf 
+# from sway config file
+exec_always "~/.config/sway/init.scm"
+#+end_src
+
+2- I plan to publish a module for =swayipc=, it's currently not hosted anywhere. You'll need to add the module to your =load path=. Additionally, =swayipc= includes another patched Guile library called =guile-json=, which is embedded for now. In the future, this will be included as a separate dependency rather than embedded.
+
+#+begin_src scheme 
+(add-to-load-path
+ (dirname (or (current-filename)
+              (string-append (getenv "HOME") "/.config/sway/init.scm"))))
+#+end_src

behavior.scm

@@ -0,0 +1,9 @@
+(use-modules (swayipc dispatcher))
+
+(sway-output "HDMI-A-2" "resolution 1920x1080 position 0,0")
+(sway-output "DP-1" "resolution 1920x1080 position 0,0")
+(sway-output "DP-2" "resolution 1920x1080 position 0,0")
+
+(sway-output "*" "bg /home/ebeem/dotfiles/.wallpapers/fixed/flat-20.png fill")
+
+(sway-focus-follow-mouse SWAY-FOCUS-FOLLOW-MOUSE-FLAG-NO)

commander

@@ -0,0 +1,39 @@
+#!/usr/bin/guile \
+-e main -s
+!#
+;; #!/usr/bin/guile --fresh-auto-compile
+;; ensure that the swayipc module is available under the same directory as the init file
+;; otherwise, the module should be referenced from packaging system or via custom load path
+
+(add-to-load-path
+ (dirname (or (current-filename)
+              (string-append (getenv "HOME") "/.config/sway/init.scm"))))
+
+(use-modules (swayipc connection)
+             (ice-9 popen)
+             (sjson builder)
+             (ice-9 binary-ports)
+             (rnrs bytevectors)
+             (rnrs io ports)
+             (oop goops)
+             (srfi srfi-18)
+             (srfi srfi-9)
+             (srfi srfi-1))
+
+(define COMMANDS-CLIENT-SOCKET (socket AF_UNIX SOCK_STREAM 0))
+(display (string-append "connecting to " SOCKET-COMMANDS-LISTENER-PATH "\n"))
+(connect COMMANDS-CLIENT-SOCKET
+         (make-socket-address AF_UNIX SOCKET-COMMANDS-LISTENER-PATH))
+(display "connected\n")
+
+(define (send-command command)
+  (display (string-append "sending command: " command "\n"))
+  (display (write-msg COMMANDS-CLIENT-SOCKET
+             RUN-COMMMAND-MSG-ID
+             (scm->json-string command)))
+  (display "sent\n"))
+
+(define (main args)
+  (display (string-join (cdr args) " "))
+  (newline)
+  (send-command (string-join (cdr args) " ")))

config

@@ -0,0 +1,2 @@
+include /etc/sway/config.d/*
+exec_always "~/.config/sway/init.scm"

init.scm

@@ -0,0 +1,51 @@
+#!/usr/bin/guile
+!#
+
+(add-to-load-path
+ (dirname (or (current-filename)
+              (string-append (getenv "HOME") "/.config/sway/init.scm"))))
+
+(use-modules (oop goops)
+             (srfi srfi-18)
+             (modules workspace-groups)
+             (modules workspace-grid)
+             (swayipc connection)
+             (swayipc records)
+             (swayipc info)
+             (swayipc events)
+             (swayipc dispatcher))
+
+(load "behavior.scm")
+;; init keybindings
+(load "keybindings.scm")
+(keybindings-init)
+
+;; subscribe to all events
+(sway-subscribe-all)
+
+(set! OUTPUTS '("HDMI-A-2" "DP-1" "DP-2"))
+(set! GROUPS
+  '(("11-browser" 		"21-browser" 		"31-browser")
+    ("12-development" 	"22-development" 	"32-development")
+    ("13-databases" 	"23-databases" 		"33-databases")
+    ("14-communication" "24-communication" 	"34-communication")
+    ("15-development" 	"25-development" 	"35-development")
+    ("16-gaming" 		"26-gaming" 		"36-gaming")
+    ("17-mail" 			"27-mail" 			"37-mail")
+    ("18-development" 	"28-development" 	"38-development")
+    ("19-media" 		"29-media" 			"39-media")))
+
+(workspace-groups-init)
+
+(set! ROWS 3)
+(set! COLUMNS 3)
+(set! WORKSPACES (apply map list GROUPS))
+
+(workspace-grid-init)
+
+;; TODO: load which key module
+
+(start-commands-listener-thread)
+(start-event-listener-thread)
+(thread-join! LISTENER-THREAD)
+(thread-join! COMMANDS-LISTENER-THREAD)

keybindings.scm

@@ -0,0 +1,122 @@
+(use-modules (modules kbd)
+             (modules general)
+             (ice-9 popen)
+             (srfi srfi-18)
+             (ice-9 textual-ports))
+
+(define (exec command)
+  "execute given shell command"
+  (display (string-append "running " command "\n"))
+  (thread-start! (make-thread (lambda () (system command)))))
+
+(define (custom-sway-keybinding-translator key)
+  "Translates keybindings, passing kbd function will enable emacs
+   like key chords. The default implementation doesn't modify passed keybindings"
+  (kbd key))
+
+(define (keybindings-init)
+  (kbd-init)
+
+  ;; (configure-sway-keybinding-translator custom-sway-keybinding-translator)
+  (define general-module (resolve-module '(modules general)))
+  (configure-sway-keybinding-translator custom-sway-keybinding-translator)
+
+  ;; define root keybindings
+  (sway-define-keys
+   ;; media-keys
+   `("XF86AudioLowerVolume" (exec "pactl set-sink-volume @DEFAULT_SINK@ -5%"))
+   `("XF86AudioRaiseVolume" (exec "pactl set-sink-volume @DEFAULT_SINK@ +5%"))
+   `("s-[" (exec "pactl set-sink-volume @DEFAULT_SINK@ -5%"))
+   `("s-]" (exec "pactl set-sink-volume @DEFAULT_SINK@ +5%"))
+   `("XF86AudioMute" (exec "pactl set-sink-mute @DEFAULT_SINK@ toggle"))
+   `("XF86AudioNext" (exec "mpc next"))
+   `("XF86AudioPrev" (exec "mpc prev"))
+   `("XF86AudioPlay" (exec "mpc toggle"))
+
+   ;; brightness-keys
+   `("XF86MonBrightnessUp" (exec "brightnessctl set +10%"))
+   `("XF86MonBrightnessDown" (exec "brightnessctl set 10%-"))
+
+   ;; window and group management
+   `("s-f" (sway-fullscreen SWAY-FULLSCREEN-TOGGLE))
+
+   ;; move focus
+   `("s-h" (sway-focus-container SWAY-DIRECTION-LEFT))
+   `("s-j" (sway-focus-container SWAY-DIRECTION-DOWN))
+   `("s-k" (sway-focus-container SWAY-DIRECTION-UP))
+   `("s-l" (sway-focus-container SWAY-DIRECTION-RIGHT))
+
+   ;; move containers
+   `("s-S-h" (sway-move-container SWAY-DIRECTION-LEFT))
+   `("s-S-j" (sway-move-container SWAY-DIRECTION-DOWN))
+   `("s-S-k" (sway-move-container SWAY-DIRECTION-UP))
+   `("s-S-l" (sway-move-container SWAY-DIRECTION-RIGHT))
+
+   ;; switch workspace
+   `("s-C-h" (switch-workspace-left))
+   `("s-C-j" (switch-workspace-down))
+   `("s-C-k" (switch-workspace-up))
+   `("s-C-l" (switch-workspace-right))
+
+   ;; move container to workspace
+   `("s-M-C-h" (move-container-to-workspace-left))
+   `("s-M-C-j" (move-container-to-workspace-down))
+   `("s-M-C-k" (move-container-to-workspace-up))
+   `("s-M-C-l" (move-container-to-workspace-right))
+
+    ;; ;; Tab like cycling
+    ;; (define-key *top-map* (kbd "s-.") "next-in-frame")
+    ;; (define-key *top-map* (kbd "s-,") "prev-in-frame")
+
+   `("s-w" (sway-kill))
+   `("s-Return" (exec "alacritty"))
+   `("M-s-Space" (exec "~/.bin/switch-keyboard-layout"))
+   `("C-s-Space" (exec "rofi -show drun")))
+
+  ;; define leader keymap
+  (sway-define-keys
+   #:prefix "s-Space" #:wk "Leader"
+   `("o" (exec "rofi -show drun"))
+   `("C-g" (sway-mode "default") #:wk "abort")
+
+   ;; rofi keymap
+   `(sway-define-keys
+     #:prefix "r" #:wk "Rofi"
+     ("p" (exec "~/.config/rofi/bin/password-manager"))
+     ("m" (exec "rofi-mount"))
+     ("u" (exec "rofi-unmount"))
+     ("w" (exec ".config/rofi/bin/wifi"))
+     ("b" (exec "~/.config/rofi/bin/bluetooth"))
+     ("f" (exec "~/.config/rofi/bin/finder"))
+     ("k" (exec "~/.config/rofi/bin/keyboard-layout"))
+     ("P" (exec "~/.config/rofi/bin/powermenu"))
+     ("s" (exec "~/.config/rofi/bin/sound-input"))
+     ("S" (exec "~/.config/rofi/bin/sound-output")))
+
+   ;; screenshot keymap
+   `(sway-define-keys
+     #:prefix "s" #:wk "Screenshot"
+     ("d" (exec "export XDG_CURRENT_DESKTOP=sway && flameshot gui"))
+     ("s" (exec "export XDG_CURRENT_DESKTOP=sway && flameshot screen"))
+     ("f" (exec "export XDG_CURRENT_DESKTOP=sway && flameshot full"))
+     ("m" (exec "export XDG_CURRENT_DESKTOP=sway && flameshot gui --last-region"))
+
+     (sway-define-keys
+      #:prefix "d" #:wk "DelayScreenshot"
+      ("d" (exec "export XDG_CURRENT_DESKTOP=sway && flameshot gui -d 2500"))
+      ("s" (exec "export XDG_CURRENT_DESKTOP=sway && flameshot screen -d 2500"))
+      ("f" (exec "export XDG_CURRENT_DESKTOP=sway && flameshot full -d 2500"))
+      ("l" (exec "export XDG_CURRENT_DESKTOP=sway && flameshot gui -d 2500 --last-region"))))
+
+   ;; session keymap
+   `(sway-define-keys
+     #:prefix "q" #:wk "Session"
+     ("q" (sway-exit))
+     ("r" (sway-reload)))
+
+   `(sway-define-keys
+     #:prefix "w" #:wk "Window"
+     ("v" (sway-split-container SWAY-SPLIT-VERTICAL))
+     ("h" (sway-split-container SWAY-SPLIT-HORIZONTAL))
+     ("f" (sway-fullscreen SWAY-FULLSCREEN-TOGGLE))
+     ("d" (sway-fullscreen SWAY-FULLSCREEN-TOGGLE)))))

modules/auto-reload.scm

@@ -0,0 +1,4 @@
+(define-module (modules which-key)
+  #:use-module (swayipc dispatcher)
+  #:export ())
+

modules/general.scm

@@ -0,0 +1,124 @@
+(define-module (modules general)
+  #:use-module (sjson parser)
+  #:use-module (swayipc dispatcher)
+  #:use-module (swayipc connection)
+  #:use-module (srfi srfi-18)
+  #:use-module (ice-9 hash-table)
+  #:export (sway-keybinding-translator
+            configure-sway-keybinding-translator
+            sway-define-keys
+            sway-define-key
+            sway-keybindings
+            sway-submaps))
+
+;; Local copy of keybindings configured by general, it's recommended to
+;; only use general to assign keybindings, otherwise this hashtable won't
+;; by synced with actual keybindings available in sway
+(define sway-keybindings (make-hash-table))
+
+;; Local copy of submaps configured by general, it's recommended to
+;; only use general to assign submaps, otherwise this hashtable won't
+;; by synced with actual submaps available in sway"
+(define sway-submaps (make-hash-table))
+(hash-set! sway-submaps "" "default")
+
+(define (sway-keybinding-translator key)
+  "Translates keybindings, passing kbd function will enable emacs
+   like key chords. The default implementation doesn't modify passed keybindings"
+  key)
+
+(define (configure-sway-keybinding-translator proc)
+  (set! sway-keybinding-translator proc))
+
+(define (exp->string exp)
+  (call-with-output-string (lambda (p)
+                             (write exp p))))
+
+(define* (define-submap chord key wk submap parent-submap)
+  (display (string-append "define submap " chord "\n"))
+  (hash-set! sway-submaps chord submap)
+  (define-keybindings chord key
+    `(sway-mode ,submap)
+    wk parent-submap)
+  (define-keybindings (string-append chord " Esc")
+    "Escape" `(sway-mode "default")
+    "Escape" submap))
+
+(define (last-key key)
+  (car (reverse (string-split key #\+))))
+
+(define (sway-command exp-str)
+  (string-append "exec '" (dirname (dirname (current-filename))) "/commander "
+                 (exp->string exp-str) "'"))
+
+(define* (define-keybindings chord key exp wk submap)
+  (hash-set! sway-keybindings chord '(key exp wk submap))
+  (let* ((type (if (string->number (last-key key)) "bindcode" "bindsym"))
+         (command (string-append type " " key " " (sway-command (exp->string exp))))
+         (esc (string-append type " " key " " (sway-command (exp->string `(and ,exp (sway-mode "default")))))))
+    (if (equal? submap "default")
+      (dispatch-command command)
+      (begin
+        (sway-mode-subcommand submap command)
+        (unless (equal? "sway-mode" (symbol->string (car exp)))
+          (display "escape after executing\n")
+          (display esc)
+          (sway-mode-subcommand submap esc))))))
+
+(define (find-submap chord)
+  (or
+   (hash-get-handle sway-submaps
+                    (string-join
+                     (list-head chord (- (length chord) 1)) " "))
+   (error 'find-submap "chord was not found in submaps, a submap has to be defined for it" chord)))
+
+(define* (sway-define-key chord #:optional exp #:key wk submap)
+  "assign a key to a given expression"
+  (let* ((chord-ls
+          (map sway-keybinding-translator
+               (string-split chord #\Space)))
+         (chord (string-join chord-ls " "))
+         (key (car (last-pair chord-ls)))
+         (key-code (string->number key))
+         (description (or wk (or submap (symbol->string (car exp))))))
+    (if submap
+        (define-submap chord key wk submap
+          (cdr (find-submap chord-ls)))
+        (define-keybindings chord key exp wk
+          (cdr (find-submap chord-ls))))))
+
+(define* (sway-define-keys #:key parent-prefix prefix wk . args )
+  (when parent-prefix
+    (set! prefix (string-append parent-prefix " " prefix)))
+
+  (when prefix
+    (display (string-append "define prefix submap: " prefix ", wk " wk "\n"))
+    (sway-define-key prefix #:submap wk))
+
+  (map (lambda (arg)
+         (when (list? arg)
+
+            (display "ARG: ")
+            (display arg)
+            (newline)
+            (display (car arg))
+            (newline)
+            (if (and
+                 (symbol? (car arg))
+                 (equal? "sway-define-keys" (symbol->string (car arg))))
+              (apply sway-define-keys (append `(#:parent-prefix ,prefix) (cdr arg)))
+              (apply sway-define-key
+                  (cons (string-append
+                        (if prefix (string-append prefix " ") "")
+                        (car arg)) (cdr arg))))))
+       args))
+
+(define (custom-exception-handler exc command-id payload)
+  (display "An error occurred: ")
+  (display (exp->string exc))
+  (newline)
+  (display (string-append "command: " (number->string command-id) ", payload: " payload)))
+
+(add-hook! command-received-hook
+           (lambda (command-id payload)
+            (eval-string (json-string->scm payload))))

modules/which-key.scm

@@ -0,0 +1,4 @@
+(define-module (modules which-key)
+  #:use-module (swayipc dispatcher)
+  #:export ())
+

modules/workspace-grid.scm

@@ -0,0 +1,167 @@
+;; use example:
+
+;; (set! WORKSPACES
+;; (("10" "11" "12" "13" "14" "15" "16" "17" "18" "19")
+;;  ("20" "21" "22" "23" "24" "25" "26" "27" "28" "29")
+;;  ("30" "31" "32" "33" "34" "35" "36" "37" "38" "39"))
+
+;; (set! ROWS 3)
+;; (set! COLUMNS 3)
+
+;; (workspace-grid-init)
+
+(define-module (modules workspace-grid)
+  #:use-module (swayipc records)
+  #:use-module (swayipc info)
+  #:use-module (swayipc dispatcher)
+  #:use-module (swayipc events)
+
+  #:export (
+            WORKSPACES
+            COLUMNS
+            ROWS
+            configure-workspaces
+            configure-rows
+            configure-columns
+            get-active-workspace-index
+            switch-workspace-up
+            switch-workspace-right
+            switch-workspace-down
+            switch-workspace-left
+            move-container-to-workspace-up
+            move-container-to-workspace-right
+            move-container-to-workspace-down
+            move-container-to-workspace-left
+            valid-grid?
+            workspace-grid-init))
+
+;; The order in which the outputs are organized, it's important that
+;; the order of outputs match the order of workspaces in `WORKSPACE`
+;; example:
+;; (set! WORKSPACES '(("ws-o1-1" "ws-o1-2" "ws-o1-3") ("ws-o2-1" "ws-o2-2" "ws-o2-3"))
+(define WORKSPACES '())
+
+;; number of rows in the grid
+(define ROWS 1)
+;; number of columns in the grid
+(define COLUMNS 1)
+
+(define (configure-workspaces workspaces)
+  (set! WORKSPACES workspaces))
+
+(define (configure-rows rows)
+  (set! ROWS rows))
+
+(define (configure-columns columns)
+  (set! COLUMNS columns))
+
+(define* (get-active-workspace-name #:optional (workspaces (sway-get-workspaces)))
+  "get name of active workspace"
+  (cond
+   ((null? workspaces) #f)
+   ((equal? (sway-workspace-focused (car workspaces)) #t)
+    (sway-workspace-name (car workspaces)))
+   (else (get-active-workspace-name (cdr workspaces)))))
+
+(define* (get-output-index workspace #:optional (workspaces WORKSPACES) (index 0))
+  "get output index of target workspace"
+  (cond
+   ((null? workspaces) #f)
+   ((member workspace (car workspaces)) index)
+   (else (get-output-index workspace (cdr workspaces) (+ index 1)))))
+
+(define* (get-workspace-index workspace #:optional
+                             (workspaces
+                              (list-ref WORKSPACES (get-output-index workspace))))
+  "get index of target workspace"
+  (let* ((memberls (member workspace workspaces)))
+    (if memberls (- (length workspaces) (length memberls)))))
+
+(define (get-active-workspace-index)
+  "get index of active/focused workspace"
+  (let* ((workspace (get-active-workspace-name)))
+    (get-workspace-index workspace)))
+
+;; available directions, up, right, down, left
+(define* (get-workspace-direction direction #:optional (index -1))
+  "get the index the next workspace after applying the direction"
+  (let* ((index (if (< index 0) (get-active-workspace-index) index))
+         (current-row (floor (/ index COLUMNS)))
+         (current-column (modulo index COLUMNS))
+         (target-row
+          (cond ((equal? direction "up") (- current-row 1))
+                ((equal? direction "down") (+ current-row 1))
+                (else current-row)))
+         (target-column
+          (cond ((equal? direction "left") (- current-column 1))
+                ((equal? direction "right") (+ current-column 1))
+                (else current-column))))
+    (+ (* COLUMNS (modulo target-row ROWS))
+       (modulo target-column COLUMNS))))
+
+(define* (get-workspace-name  #:optional
+                              (workspace (get-active-workspace-index))
+                              (output (get-output-index (get-active-workspace-name))))
+  (list-ref (list-ref WORKSPACES output) workspace))
+
+;; exposed command for easier access
+(define (switch-workspace-up)
+  (sway-switch-workspace
+   (get-workspace-name
+    (get-workspace-direction "up"))))
+
+(define (switch-workspace-right)
+  (sway-switch-workspace
+   (get-workspace-name
+    (get-workspace-direction "right"))))
+
+(define (switch-workspace-down)
+  (sway-switch-workspace
+   (get-workspace-name
+    (get-workspace-direction "down"))))
+
+(define (switch-workspace-left)
+  (sway-switch-workspace
+   (get-workspace-name
+    (get-workspace-direction "left"))))
+
+(define (move-container-to-workspace-up)
+  (sway-move-container-to-workspace
+   (get-workspace-name
+    (get-workspace-direction "up")))
+  (switch-workspace-up))
+
+(define (move-container-to-workspace-right)
+  (sway-move-container-to-workspace
+   (get-workspace-name
+    (get-workspace-direction "right")))
+  (switch-workspace-right))
+
+(define (move-container-to-workspace-down)
+  (sway-move-container-to-workspace
+   (get-workspace-name
+    (get-workspace-direction "down")))
+  (switch-workspace-down))
+
+(define (move-container-to-workspace-left)
+  (sway-move-container-to-workspace
+   (get-workspace-name
+    (get-workspace-direction "left")))
+  (switch-workspace-left))
+
+(define (valid-grid? rows columns workspaces)
+  "validate the grid structure"
+  (and (> (length workspaces) 0)
+       (equal? (* rows columns) (length (car workspaces)))))
+
+(define (workspace-grid-init)
+  (display "starting workspace-grid\n")
+  (display WORKSPACES)
+  (newline)
+  (if (valid-grid? ROWS COLUMNS WORKSPACES)
+    (display (string-append "successfully started workspace "
+                            (number->string ROWS) "x"
+                            (number->string COLUMNS) "\n"))
+    (display (string-append "workspace grid failed to start the grid configs "
+                            (number->string ROWS) "x"
+                            (number->string COLUMNS) "\n"))))

modules/workspace-groups.scm

@@ -0,0 +1,110 @@
+;; use example:
+
+;; (set! OUTPUTS '("HDMI-A-2" "DP-1" "DP-2"))
+;; (set! GROUPS
+;;   '(("10" "20" "30")
+;;     ("11" "21" "31")
+;;     ("12" "22" "32")
+;;     ("13" "23" "33")
+;;     ("14" "24" "34")
+;;     ("15" "25" "35")
+;;     ("16" "26" "36")
+;;     ("17" "27" "37")
+;;     ("18" "28" "38")
+;;     ("19" "29" "39")))
+
+;; (workspace-groups-init)
+
+(define-module (modules workspace-groups)
+  #:use-module (swayipc records)
+  #:use-module (swayipc info)
+  #:use-module (swayipc dispatcher)
+  #:use-module (swayipc events)
+
+  #:export (workspace-groups-init
+            OUTPUTS
+            GROUPS))
+
+;; The order in which the outputs are organized, it's important that
+;; the order of outputs match the order of workspaces in `WORKSPACE-GROUPS`
+;; example:
+;; (set! OUTPUTS '("HDMI-A-2" "DP-1" "DP-2"))
+(define OUTPUTS '())
+
+;; The workspace groups, each is a list of workspace names
+;; if a workspace of this list is activated, the rest of the workspaces
+;; will be activated as well.
+;; example: 
+;; (set! GROUPS
+;;   '(("10" "20" "30")
+;;     ("19" "29" "39")))
+(define GROUPS '())
+
+(define (configure-outputs outputs)
+  (set! OUTPUTS outputs))
+
+(define (configure-groups groups)
+  (set! GROUPS groups))
+
+(define last-switched-group '())
+
+(define (is-workspace-focused workspace output outputs)
+  (cond
+   ((null? outputs) #f)
+   ((equal? output (sway-output-name (car outputs)))
+    (equal? workspace (sway-output-current-workspace (car outputs))))
+   (else (is-workspace-focused workspace output (cdr outputs)))))
+
+(define (switch-to-workspace-group group initiator)
+  (unless (equal? last-switched-group group)
+    (let* ((initiator-output "")
+           (outputs (sway-get-outputs)))
+      (set! last-switched-group group)
+      (newline)
+      (for-each
+        (lambda (workspace output)
+          (if (equal? workspace initiator)
+              (set! initiator-output output)
+              (unless (is-workspace-focused workspace output outputs)
+                (sway-switch-workspace workspace))))
+        group OUTPUTS)
+
+      ;; switch to initiator at last so the focus behaves as expected
+      (sway-switch-workspace initiator))))
+
+(define (focused-workspace workspaces)
+  (cond
+   ((null? workspaces) #f)
+   ((equal? #t (sway-workspace-focused (car workspaces)))
+    (sway-workspace-name (car workspaces)))
+   (else (focused-workspace (cdr workspaces)))))
+
+(define (workspace-changed workspace-event)
+  (let* ((current-tree (sway-workspace-event-current workspace-event))
+         (workspace (sway-tree-name current-tree))
+         (focused-workspace (focused-workspace (sway-get-workspaces))))
+
+    ;; sometimes there is a delay in events, it's neccessary to ensure
+    ;; that event workspace is same as the currently focused workspace
+    (when (equal? workspace focused-workspace)
+      (unless (member workspace last-switched-group)
+        (set! last-switched-group '()))
+      (for-each
+      (lambda (group)
+        (when (member workspace group)
+          (switch-to-workspace-group group workspace)))
+    GROUPS))))
+
+(define (pin-workspaces-to-output groups outputs)
+  (for-each
+   (lambda (group)
+     (for-each
+      (lambda (workspace output)
+        (sway-switch-workspace-on-output workspace output))
+      group outputs))
+   groups))
+
+(define (workspace-groups-init)
+  ;; pin workspaces to output
+  (pin-workspaces-to-output GROUPS OUTPUTS)
+  (add-hook! sway-workspace-hook workspace-changed))

sjson/builder.scm

@@ -0,0 +1,280 @@
+;;; (json builder) --- Guile JSON implementation.
+
+;; Copyright (C) 2013-2020 Aleix Conchillo Flaque <aconchillo@gmail.com>
+;; Copyright (C) 2015,2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;
+;; This file is part of guile-json.
+;;
+;; guile-json is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; guile-json is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with guile-json. If not, see https://www.gnu.org/licenses/.
+
+;;; Commentary:
+
+;; JSON module for Guile
+
+;;; Code:
+
+(define-module (sjson builder)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-43)
+  #:export (scm->json
+            scm->json-string
+            scm->json-seq
+            scm->json-seq-string))
+
+
+;;
+;; Miscellaneuos helpers
+;;
+
+(define (indent-string pretty level)
+  (if pretty (format #f "~v_" (* 2 level)) ""))
+
+;;
+;; String builder helpers
+;;
+
+(define (unicode->json-string unicode)
+  (format #f "\\u~4,'0x" unicode))
+
+(define (unicode->json-surrogate-pair unicode)
+  (let* ((u (- unicode #x10000))
+         (w1 (+ #xD800 (ash u -10)))
+         (w2 (+ #xDC00 (logand u #x3ff))))
+    (string-append (unicode->json-string w1)
+                   (unicode->json-string w2))))
+
+(define (build-json-unicode c)
+  (let* ((value (char->integer c)))
+    (cond
+     ((< value 32)
+      (unicode->json-string value))
+     ((<= value 255)
+      (string c))
+     ((<= value #xFFFF)
+      (unicode->json-string value))
+     ((<= value #x10FFFF)
+      (unicode->json-surrogate-pair value))
+     (else (throw 'json-invalid (string c))))))
+
+(define (->string x)
+  (cond ((char? x) (make-string 1 x))
+        ((number? x) (number->string x))
+        ((symbol? x) (symbol->string x))
+        (else x)))
+
+(define (build-string c port solidus unicode)
+  (case c
+    ((#\" #\\) (format port "\\~c" c))
+    ((#\bs) (put-string port "\\b"))
+    ((#\ff) (put-string port "\\f"))
+    ((#\lf) (put-string port "\\n"))
+    ((#\cr) (put-string port "\\r"))
+    ((#\ht) (put-string port "\\t"))
+    ((#\/) (if solidus
+               (put-string port "\\/")
+               (put-char port c)))
+    (else (if unicode
+              (put-string port (build-json-unicode c))
+              (put-char port c)))))
+
+(define (json-build-string scm port solidus unicode)
+  (put-string port "\"")
+  (for-each (lambda (c) (build-string c port solidus unicode))
+            (string->list (->string scm)))
+  (put-string port "\""))
+
+;;
+;; Object builder functions
+;;
+
+(define (build-object-pair p port solidus unicode null pretty level)
+  (put-string port (indent-string pretty level))
+  (json-build-string (car p) port solidus unicode)
+  (put-string port ":")
+  (build-space port pretty)
+  (json-build (cdr p) port solidus unicode null pretty level))
+
+(define (build-newline port pretty)
+  (cond (pretty (newline port))))
+
+(define (build-space port pretty)
+  (cond (pretty (put-string port " "))))
+
+(define (json-build-object scm port solidus unicode null pretty level)
+  (put-string port "{")
+  (let ((pairs scm))
+    (unless (null? pairs)
+      (build-newline port pretty)
+      (build-object-pair (car pairs) port solidus unicode null pretty (+ level 1))
+      (for-each (lambda (p)
+                  (put-string port ",")
+                  (build-newline port pretty)
+                  (build-object-pair p port solidus unicode null pretty (+ level 1)))
+                (cdr pairs))
+      (build-newline port pretty)
+      (put-string port (indent-string pretty level))))
+  (put-string port "}"))
+
+;;
+;; Array builder functions
+;;
+
+(define (json-build-array scm port solidus unicode null pretty level)
+  (put-string port "[")
+  (unless (or (null? scm) (zero? (vector-length scm)))
+    (build-newline port pretty)
+    (vector-for-each (lambda (i v)
+                       (cond
+                         ((> i 0)
+                          (put-string port ",")
+                          (build-newline port pretty)))
+                       (put-string port (indent-string pretty (+ level 1)))
+                       (json-build v port solidus unicode null pretty (+ level 1)))
+                     scm)
+    (build-newline port pretty)
+    (put-string port (indent-string pretty level)))
+  (put-string port "]"))
+
+;;
+;; Booleans, null and number builder functions
+;;
+
+(define (json-build-boolean scm port)
+  (put-string port (if scm "true" "false")))
+
+(define (json-build-null port)
+  (put-string port "null"))
+
+(define (json-build-number scm port)
+  (if (and (rational? scm) (not (integer? scm)))
+      (put-string port (number->string (exact->inexact scm)))
+      (put-string port (number->string scm))))
+
+;;
+;; Main builder functions
+;;
+
+(define (json-number? number)
+  (and (number? number) (eqv? (imag-part number) 0) (finite? number)))
+
+(define (json-key? scm)
+  (or (symbol? scm) (string? scm)))
+
+(define (json-valid? scm null)
+  (cond
+   ((eq? scm null) #t)
+   ((boolean? scm) #t)
+   ((json-number? scm) #t)
+   ((symbol? scm) #t)
+   ((string? scm) #t)
+   ((vector? scm) (vector-every (lambda (elem) (json-valid? elem null)) scm))
+   ((pair? scm)
+    (every (lambda (entry)
+	     (and (pair? entry)
+		  (json-key? (car entry))
+		  (json-valid? (cdr entry) null)))
+	   scm))
+   ((null? scm) #t)
+   (else (throw 'json-invalid scm))))
+
+(define (json-build scm port solidus unicode null pretty level)
+  (cond
+   ((eq? scm null) (json-build-null port))
+   ((boolean? scm) (json-build-boolean scm port))
+   ((json-number? scm) (json-build-number scm port))
+   ((symbol? scm) (json-build-string (symbol->string scm) port solidus unicode))
+   ((string? scm) (json-build-string scm port solidus unicode))
+   ((vector? scm) (json-build-array scm port solidus unicode null pretty level))
+   ((or (pair? scm) (null? scm))
+    (json-build-object scm port solidus unicode null pretty level))
+   (else (throw 'json-invalid scm))))
+
+;;
+;; Public procedures
+;;
+
+(define* (scm->json scm
+                    #:optional (port (current-output-port))
+                    #:key
+                    (solidus #f) (unicode #f) (null 'null)
+                    (validate #t) (pretty #f))
+  "Creates a JSON document from native. The argument @var{scm} contains the
+native value of the JSON document. Takes one optional argument, @var{port},
+which defaults to the current output port where the JSON document will be
+written. It also takes a few keyword arguments: @{solidus}: if true, the
+slash (/ solidus) character will be escaped (defaults to false), @{unicode}:
+if true, unicode characters will be escaped when needed (defaults to false),
+@{null}: value for JSON's null (defaults to the 'null symbol), @{validate} :
+if true, the native value will be validated before starting to print the JSON
+document (defaults to true) and @{pretty}: if true, the JSON document will be
+pretty printed (defaults to false).
+
+Note that when using alists to build JSON objects, symbols or numbers might be
+used as keys and they both will be converted to strings.
+"
+  (cond
+   ((and validate (json-valid? scm null))
+    (json-build scm port solidus unicode null pretty 0))
+   (else
+    (json-build scm port solidus unicode null pretty 0))))
+
+(define* (scm->json-string scm #:key
+                           (solidus #f) (unicode #f) (null 'null)
+                           (validate #t) (pretty #f))
+  "Creates a JSON document from native into a string. The argument @var{scm}
+contains the native value of the JSON document. It also takes a few keyword
+arguments: @{solidus}: if true, the slash (/ solidus) character will be
+escaped (defaults to false), @{unicode}: if true, unicode characters will be
+escaped when needed (defaults to false), @{null}: value for JSON's
+null (defaults to the 'null symbol), @{validate} : if true, the native value
+will be validated before starting to print the JSON document (defaults to
+true) and @{pretty}: if true, the JSON document will be pretty
+printed (defaults to false).
+
+Note that when using alists to build JSON objects, symbols or numbers might be
+used as keys and they both will be converted to strings.
+"
+  (call-with-output-string
+   (lambda (p)
+     (scm->json scm p
+                #:solidus solidus #:unicode unicode #:null null
+                #:pretty pretty #:validate validate))))
+
+(define* (scm->json-seq objects #:optional (port (current-output-port))
+                        #:key (null 'null) (solidus #f) (validate #t))
+  "Create a JSON text sequence from native @var{objects} and write it.
+The optional argument @var{port} specifies the output port, which defaults to
+the current output port. This procedure also takes a subset of
+@code{json->scm} keyword arguments - @{null}, @{solidus} and @{validate}.
+@{unicode} and @{pretty} are unsupported because RFC 7464 requires JSON text
+sequences to be written in UTF-8, one per line."
+  (define (put-entry object)
+    (put-char port #\rs)
+    (scm->json object port
+               #:unicode #t #:null null #:solidus solidus #:validate validate)
+    (put-char port #\lf))
+  (for-each put-entry objects))
+
+(define* (scm->json-seq-string objects
+                               #:key (null 'null) (solidus #f) (validate #t))
+  "Create a JSON text sequence from native @var{objects} and return it.
+This procedure takes the same keyword arguments as @code{scm->json-seq}."
+  (call-with-output-string
+    (lambda (port)
+      (scm->json-seq objects port
+                     #:null null #:solidus solidus #:validate validate))))
+
+;;; (json builder) ends here

sjson/parser.scm

@@ -0,0 +1,490 @@
+;;; (json parser) --- Guile JSON implementation.
+
+;; Copyright (C) 2013-2020 Aleix Conchillo Flaque <aconchillo@gmail.com>
+;;
+;; This file is part of guile-json.
+;;
+;; guile-json is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; guile-json is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with guile-json. If not, see https://www.gnu.org/licenses/.
+
+;;; Commentary:
+
+;; JSON module for Guile
+
+;;; Code:
+
+(define-module (sjson parser)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 streams)
+  #:use-module (rnrs io ports)
+  #:export (json->scm
+            json-string->scm
+            json-seq->scm
+            json-seq-string->scm))
+
+;;
+;; Miscellaneuos helpers
+;;
+
+(define (json-exception port)
+  (throw 'json-invalid port))
+
+(define (digit? c)
+  (case c
+    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) #t)
+    (else #f)))
+
+(define (whitespace? c)
+  (case c
+    ((#\sp #\ht #\lf #\cr) #t)
+    (else #f)))
+
+(define (control-char? ch)
+  (<= (char->integer ch) #x1F))
+
+(define (skip-whitespaces port)
+  (let ((ch (peek-char port)))
+    (cond
+     ((whitespace? ch)
+      (read-char port)
+      (skip-whitespaces port))
+     (else *unspecified*))))
+
+(define (expect-string port expected return)
+  (let loop ((n 0))
+    (cond
+     ;; All characters match.
+     ((= n (string-length expected)) return)
+     ;; Go to next characters.
+     ((eqv? (read-char port) (string-ref expected n))
+      (loop (+ n 1)))
+     ;; Anything else is an error.
+     (else (json-exception port)))))
+
+(define (expect-delimiter port delimiter)
+  (let ((ch (read-char port)))
+    (cond
+     ((not (eqv? ch delimiter)) (json-exception port))
+     ;; Unexpected EOF.
+     ((eof-object? ch) (json-exception port)))))
+
+(define (skip-record-separators port)
+  (when (eqv? #\rs (peek-char port))
+    (read-char port)
+    (skip-record-separators port)))
+
+;;
+;; Number parsing helpers
+;;
+
+(define (expect-digit port)
+  (let ((ch (peek-char port)))
+    (cond
+     ((not (digit? ch)) (json-exception port))
+     ;; Unexpected EOF.
+     ((eof-object? ch) (json-exception port)))))
+
+;; Read + or -, and return 1 or -1 respectively. If something different is
+;; found, return 1.
+(define (read-sign port)
+  (let ((ch (peek-char port)))
+    (cond
+     ((eqv? ch #\+)
+      (read-char port)
+      1)
+     ((eqv? ch #\-)
+      (read-char port)
+      -1)
+     (else 1))))
+
+(define (read-digit-value port)
+  (let ((ch (read-char port)))
+    (cond
+     ((eqv? ch #\0) 0)
+     ((eqv? ch #\1) 1)
+     ((eqv? ch #\2) 2)
+     ((eqv? ch #\3) 3)
+     ((eqv? ch #\4) 4)
+     ((eqv? ch #\5) 5)
+     ((eqv? ch #\6) 6)
+     ((eqv? ch #\7) 7)
+     ((eqv? ch #\8) 8)
+     ((eqv? ch #\9) 9)
+     (else (json-exception port)))))
+
+;; Read digits [0..9].
+(define (read-digits port)
+  (expect-digit port)
+  (let loop ((ch (peek-char port)) (number 0))
+    (cond
+     ((digit? ch)
+      (let ((value (read-digit-value port)))
+        (loop (peek-char port) (+ (* number 10) value))))
+     (else number))))
+
+(define (read-digits-fraction port)
+  (expect-digit port)
+  (let loop ((ch (peek-char port)) (number 0) (length 0))
+    (cond
+     ((digit? ch)
+      (let ((value (read-digit-value port)))
+        (loop (peek-char port) (+ (* number 10) value) (+ length 1))))
+     (else
+      (/ number (expt 10 length))))))
+
+(define (read-exponent port)
+  (let ((ch (peek-char port)))
+    (cond
+     ((or (eqv? ch #\e) (eqv? ch #\E))
+      (read-char port)
+      (let ((sign (read-sign port))
+            (digits (read-digits port)))
+        (if (<= digits 1000) ;; Some maximum exponent.
+            (expt 10 (* sign digits))
+            (json-exception port))))
+     (else 1))))
+
+(define (read-fraction port)
+  (let ((ch (peek-char port)))
+    (cond
+     ((eqv? ch #\.)
+      (read-char port)
+      (read-digits-fraction port))
+     (else 0))))
+
+(define (read-positive-number port)
+  (let* ((number
+          (let ((ch (peek-char port)))
+            (cond
+             ;; Numbers that start with 0 must be a fraction.
+             ((eqv? ch #\0)
+              (read-char port)
+              0)
+             ;; Otherwise read more digits.
+             (else (read-digits port)))))
+         (fraction (read-fraction port))
+         (exponent (read-exponent port))
+         (result (* (+ number fraction) exponent)))
+    (if (and (zero? fraction) (>= exponent 1))
+        result
+        (exact->inexact result))))
+
+(define (json-read-number port)
+  (let ((ch (peek-char port)))
+    (cond
+     ;; Negative numbers.
+     ((eqv? ch #\-)
+      (read-char port)
+      (expect-digit port)
+      (* -1 (read-positive-number port)))
+     ;; Positive numbers.
+     ((digit? ch)
+      (read-positive-number port))
+     ;; Anything else is an error.
+     (else (json-exception port)))))
+
+;;
+;; Object parsing helpers
+;;
+
+(define (read-pair port null ordered)
+  ;; Read key.
+  (let ((key (json-read-string port)))
+    (skip-whitespaces port)
+    (let ((ch (peek-char port)))
+      (cond
+       ;; Skip colon and read value.
+       ((eqv? ch #\:)
+        (read-char port)
+        (cons key (json-read port null ordered)))
+       ;; Anything other than colon is an error.
+       (else (json-exception port))))))
+
+(define (uniquify-keys pairs res)
+  (cond ((null? pairs) res)
+        ((assoc (caar pairs) res)
+         (uniquify-keys (cdr pairs) res))
+        (else (uniquify-keys (cdr pairs) (cons (car pairs) res)))))
+
+(define (json-read-object port null ordered)
+  (expect-delimiter port #\{)
+  (let loop ((pairs '()) (added #t))
+    (skip-whitespaces port)
+    (let ((ch (peek-char port)))
+      (cond
+       ;; End of object.
+       ((eqv? ch #\})
+        (read-char port)
+        (cond
+         (added (if ordered
+                    (uniquify-keys pairs '())
+                    (reverse! (uniquify-keys pairs '()))))
+         (else (json-exception port))))
+       ;; Read one pair and continue.
+       ((eqv? ch #\")
+        (let ((pair (read-pair port null ordered)))
+          (loop (cons pair pairs) #t)))
+       ;; Skip comma and read more pairs.
+       ((eqv? ch #\,)
+        (read-char port)
+        (cond
+         (added (loop pairs #f))
+         (else (json-exception port))))
+       ;; Invalid object.
+       (else (json-exception port))))))
+
+;;
+;; Array parsing helpers
+;;
+
+(define (json-read-array port null ordered)
+  (expect-delimiter port #\[)
+  (skip-whitespaces port)
+  (cond
+   ;; Special case when array is empty.
+   ((eqv? (peek-char port) #\])
+    (read-char port)
+    #())
+   (else
+    ;; Read first element in array.
+    (let loop ((values (list (json-read port null ordered))))
+      (skip-whitespaces port)
+      (let ((ch (peek-char port)))
+        (cond
+         ;; Unexpected EOF.
+         ((eof-object? ch) (json-exception port))
+         ;; Handle comma (if there's a comma there should be another element).
+         ((eqv? ch #\,)
+          (read-char port)
+          (loop (cons (json-read port null ordered) values)))
+         ;; End of array.
+         ((eqv? ch #\])
+          (read-char port)
+          (list->vector (reverse! values)))
+         ;; Anything else other than comma and end of array is wrong.
+         (else (json-exception port))))))))
+
+;;
+;; String parsing helpers
+;;
+
+(define (read-hex-digit->integer port)
+  (let ((ch (read-char port)))
+    (cond
+     ((eqv? ch #\0) 0)
+     ((eqv? ch #\1) 1)
+     ((eqv? ch #\2) 2)
+     ((eqv? ch #\3) 3)
+     ((eqv? ch #\4) 4)
+     ((eqv? ch #\5) 5)
+     ((eqv? ch #\6) 6)
+     ((eqv? ch #\7) 7)
+     ((eqv? ch #\8) 8)
+     ((eqv? ch #\9) 9)
+     ((or (eqv? ch #\A) (eqv? ch #\a)) 10)
+     ((or (eqv? ch #\B) (eqv? ch #\b)) 11)
+     ((or (eqv? ch #\C) (eqv? ch #\c)) 12)
+     ((or (eqv? ch #\D) (eqv? ch #\d)) 13)
+     ((or (eqv? ch #\E) (eqv? ch #\e)) 14)
+     ((or (eqv? ch #\F) (eqv? ch #\f)) 15)
+     (else (json-exception port)))))
+
+(define (read-unicode-value port)
+  (+ (* 4096 (read-hex-digit->integer port))
+      (* 256 (read-hex-digit->integer port))
+      (* 16 (read-hex-digit->integer port))
+      (read-hex-digit->integer port)))
+
+;; Unicode codepoint with surrogates is:
+;;   10000 + (high - D800) + (low - DC00)
+;; which is equivalent to:
+;;  (high << 10) + low - 35FDC00
+;; see
+;;   https://github.com/aconchillo/guile-json/issues/58#issuecomment-662744070
+(define (json-surrogate-pair->unicode high low)
+  (+ (* high #x400) low #x-35FDC00))
+
+(define (read-unicode-char port)
+  (let ((codepoint (read-unicode-value port)))
+    (cond
+     ;; Surrogate pairs. `codepoint` already contains the higher surrogate
+     ;; (between D800 and DC00) . At this point we are expecting another
+     ;; \uXXXX that holds the lower surrogate (between DC00 and DFFF).
+     ((and (>= codepoint #xD800) (< codepoint #xDC00))
+      (expect-string port "\\u" #f)
+      (let ((low-surrogate (read-unicode-value port)))
+        (if (and (>= low-surrogate #xDC00) (< low-surrogate #xE000))
+            (integer->char (json-surrogate-pair->unicode codepoint low-surrogate))
+            (json-exception port))))
+     ;; Reserved for surrogates (we just need to check starting from the low
+     ;; surrogates).
+     ((and (>= codepoint #xDC00) (< codepoint #xE000))
+      (json-exception port))
+     (else (integer->char codepoint)))))
+
+(define (read-control-char port)
+  (let ((ch (read-char port)))
+    (cond
+     ((eqv? ch #\") #\")
+     ((eqv? ch #\\) #\\)
+     ((eqv? ch #\/) #\/)
+     ((eqv? ch #\b) #\bs)
+     ((eqv? ch #\f) #\ff)
+     ((eqv? ch #\n) #\lf)
+     ((eqv? ch #\r) #\cr)
+     ((eqv? ch #\t) #\ht)
+     ((eqv? ch #\u) (read-unicode-char port))
+     (else (json-exception port)))))
+
+(define (json-read-string port)
+  (expect-delimiter port #\")
+  (let loop ((chars '()) (ch (read-char port)))
+    (cond
+     ;; Unexpected EOF.
+     ((eof-object? ch) (json-exception port))
+     ;; Unescaped control characters are not allowed.
+     ((control-char? ch) (json-exception port))
+     ;; End of string.
+     ((eqv? ch #\") (reverse-list->string chars))
+     ;; Escaped characters.
+     ((eqv? ch #\\)
+      (loop (cons (read-control-char port) chars) (read-char port)))
+     ;; All other characters.
+     (else
+      (loop (cons ch chars) (read-char port))))))
+
+;;
+;; Booleans and null parsing helpers
+;;
+
+(define (json-read-true port)
+  (expect-string port "true" #t))
+
+(define (json-read-false port)
+  (expect-string port "false" #f))
+
+(define (json-read-null port null)
+  (expect-string port "null" null))
+
+;;
+;; Main parser functions
+;;
+
+(define (json-read port null ordered)
+  (skip-whitespaces port)
+  (let ((ch (peek-char port)))
+    (cond
+     ;; Unexpected EOF.
+     ((eof-object? ch) (json-exception port))
+     ;; Read JSON values.
+     ((eqv? ch #\t) (json-read-true port))
+     ((eqv? ch #\f) (json-read-false port))
+     ((eqv? ch #\n) (json-read-null port null))
+     ((eqv? ch #\{) (json-read-object port null ordered))
+     ((eqv? ch #\[) (json-read-array port null ordered))
+     ((eqv? ch #\") (json-read-string port))
+     ;; Anything else should be a number.
+     (else (json-read-number port)))))
+
+;;
+;; Public procedures
+;;
+
+(define* (json->scm #:optional (port (current-input-port))
+                    #:key (null 'null) (ordered #f) (concatenated #f))
+  "Parse a JSON document into native. Takes one optional argument,
+@var{port}, which defaults to the current input port from where the JSON
+document is read. It also takes a few of keyword arguments: @{null}: value for
+JSON's null, it defaults to the 'null symbol, @{ordered} to indicate whether
+JSON objects order should be preserved or not (the default) and @{concatenated}
+which can be used to tell the parser that more JSON documents might come after a
+properly parsed document."
+  (let loop ((value (json-read port null ordered)))
+    ;; Skip any trailing whitespaces.
+    (skip-whitespaces port)
+    (cond
+     ;; If we reach the end the parsing succeeded.
+     ((eof-object? (peek-char port)) value)
+     ;; If there's anything else other than the end, check if user wants to keep
+     ;; parsing concatenated valid JSON documents, otherwise parser fails.
+     (else
+      (cond (concatenated value)
+            (else (json-exception port)))))))
+
+(define* (json-string->scm str #:key (null 'null) (ordered #f))
+  "Parse a JSON document into native. Takes a string argument,
+@var{str}, that contains the JSON document. It also takes a couple of keyword
+argument: @{null}: value for JSON's null, it defaults to the 'null symbol and
+@{ordered} to indicate whether JSON objects order should be preserved or
+not (the default)."
+  (call-with-input-string str (lambda (p) (json->scm p #:null null #:ordered ordered))))
+
+(define* (json-seq->scm #:optional (port (current-input-port))
+                        #:key (null 'null) (ordered #f)
+                        (handle-truncate 'skip) (truncated-object 'truncated))
+  "Lazy parse a JSON text sequence from the port @var{port}.
+This procedure returns a stream of parsed documents. The optional argument
+@var{port} defines the port to read from and defaults to the current input
+port. It also takes a few keyword arguments: @{null}: value for JSON's null
+(defaults to the 'null symbol), @{ordered} to indicate whether JSON objects
+order should be preserved or not (the default), @{handle-truncate}: defines how
+to handle data loss, @{truncated-object}: used to replace unparsable
+objects. Allowed values for @{handle-truncate} argument are 'throw (throw an
+exception), 'stop (stop parsing and end the stream), 'skip (default, skip
+corrupted fragment and return the next entry), 'replace (skip corrupted fragment
+and return @{truncated-object} instead)."
+  (letrec ((handle-truncation
+            (case handle-truncate
+              ((throw) json-exception)
+              ((stop) (const (eof-object)))
+              ((skip)
+               (lambda (port)
+                 (read-delimited "\x1e" port 'peek)
+                 (read-entry port)))
+              ((replace)
+               (lambda (port)
+                 (read-delimited "\x1e" port 'peek)
+                 truncated-object))))
+           (read-entry
+            (lambda (port)
+              (let ((ch (read-char port)))
+                (cond
+                 ((eof-object? ch) ch)
+                 ((not (eqv? ch #\rs))
+                  (handle-truncation port))
+                 (else
+                  (skip-record-separators port)
+                  (catch 'json-invalid
+                    (lambda ()
+                      (let ((next (json-read port null ordered)))
+                        (if (eqv? #\lf (peek-char port))
+                            (begin
+                              (read-char port)
+                              next)
+                            (handle-truncation port))))
+                    (lambda (_ port)
+                      (handle-truncation port)))))))))
+    (port->stream port read-entry)))
+
+(define* (json-seq-string->scm str #:key (null 'null) (ordered #f)
+                               (handle-truncate 'skip) (truncated-object 'truncated))
+  "Lazy parse a JSON text sequence from the string @var{str}.
+This procedure returns a stream of parsed documents and also takes the same
+keyword arguments as @code{json-seq->scm}."
+  (call-with-input-string str
+    (lambda (p)
+      (json-seq->scm p #:null null #:ordered ordered
+                     #:handle-truncate handle-truncate
+                     #:truncated-object truncated-object))))
+
+;;; (json parser) ends here

sjson/record.scm

@@ -0,0 +1,230 @@
+;;; (json record) --- Guile JSON implementation.
+
+;; Copyright (C) 2020-2021 Aleix Conchillo Flaque <aconchillo@gmail.com>
+;; Copyright (C) 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;
+;; This file is part of guile-json.
+;;
+;; guile-json is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; guile-json is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with guile-json. If not, see https://www.gnu.org/licenses/.
+
+;;; Commentary:
+
+;; JSON module for Guile
+
+;; The initial code of this file was copied from GNU Guix:
+;;  http://git.savannah.gnu.org/cgit/guix.git/tree/guix/json.scm
+
+;;; Code:
+
+(define-module (sjson record)
+  #:use-module (sjson builder)
+  #:use-module (sjson parser)
+  #:use-module (srfi srfi-9)
+  #:export (<=> define-json-mapping define-json-type))
+
+(define <=> '<=>)
+
+(define-syntax-rule (define-json-reader json->record ctor spec ...)
+  "Define JSON->RECORD as a procedure that converts a JSON representation,
+read from a port, string, or alist, into a record created by CTOR and following
+SPEC, a series of field specifications."
+  (define (json->record input)
+    (let ((table (cond ((port? input)
+                        (json->scm input))
+                       ((string? input)
+                        (json-string->scm input))
+                       ;; This allows to pass native values.
+                       ((or (null? input) (pair? input))
+                        input))))
+      (let-syntax ((extract-field (syntax-rules ()
+                                    ((_ table (field key scm->value value->scm))
+                                     (scm->value (if (and (pair? (assoc key table)) (not (equal? 'null (cdr (assoc key table)))))
+                                                     (cdr (assoc key table)) *unspecified*)))
+                                    ((_ table (field key scm->value))
+                                     (scm->value (if (and (pair? (assoc key table)) (not (equal? 'null (cdr (assoc key table)))))
+                                                     (cdr (assoc key table)) *unspecified*)))
+                                    ((_ table (field key))
+                                     (if (and (pair? (assoc key table)) (not (equal? 'null (cdr (assoc key table)))))
+                                         (cdr (assoc key table)) *unspecified*))
+                                    ((_ table (field))
+                                     (if (pair? (assoc (symbol->string 'field) table)) (cdr (assoc (symbol->string 'field) table)) *unspecified*)))))
+        (ctor (extract-field table spec) ...)))))
+
+(define-syntax-rule (define-json-writer record->json spec ...)
+  "Define RECORD->JSON as a procedure that converts a RECORD into its JSON
+representation following SPEC, a series of field specifications."
+  (define (record->json record)
+    (let-syntax ((extract-field (syntax-rules ()
+                                  ((_ (field getter key scm->value value->scm))
+                                   (cons key (if (unspecified? (getter record)) *unspecified* (value->scm (getter record)))))
+                                  ((_ (field getter key scm->value))
+                                   (cons key (getter record)))
+                                  ((_ (field getter key))
+                                   (cons key (getter record)))
+                                  ((_ (field getter))
+                                   (cons (symbol->string 'field) (getter record))))))
+      (let* ((full-object `(,(extract-field spec) ...))
+             (object (filter (lambda (p) (not (unspecified? (cdr p))))
+                             full-object)))
+        (scm->json-string object)))))
+
+(define-syntax-rule (define-native-reader scm->record ctor spec ...)
+  "Define SCM->RECORD as a procedure that converts an alist into a record
+created by CTOR and following SPEC, a series of field specifications."
+  (define (scm->record table)
+    (let-syntax ((extract-field (syntax-rules ()
+                                  ((_ table (field key scm->value value->scm))
+                                   (scm->value (if (pair? (assoc key table)) (cdr (assoc key table)) *unspecified*)))
+                                  ((_ table (field key scm->value))
+                                   (scm->value (if (pair? (assoc key table)) (cdr (assoc key table)) *unspecified*)))
+                                  ((_ table (field key))
+                                   (if (pair? (assoc key table)) (cdr (assoc key table)) *unspecified*))
+                                  ((_ table (field))
+                                   (if (pair? (assoc (symbol->string 'field) table)) (cdr (assoc (symbol->string 'field) table)) *unspecified*)))))
+      (ctor (extract-field table spec) ...))))
+
+(define-syntax-rule (define-native-writer record->scm spec ...)
+  "Define RECORD->SCM as a procedure that converts a RECORD into it an alist
+representation following SPEC, a series of field specifications."
+  (define (record->scm record)
+    (let-syntax ((extract-field (syntax-rules ()
+                                  ((_ (field getter key scm->value value->scm))
+                                   (cons key (if (unspecified? (getter record)) *unspecified* (value->scm (getter record)))))
+                                  ((_ (field getter key scm->value))
+                                   (cons key (getter record)))
+                                  ((_ (field getter key))
+                                   (cons key (getter record)))
+                                  ((_ (field getter))
+                                   (cons (symbol->string 'field) (getter record))))))
+      (let ((full-object `(,(extract-field spec) ...)))
+        (filter (lambda (p) (not (unspecified? (cdr p)))) full-object)))))
+
+(define-syntax define-json-mapping
+  (syntax-rules (<=>)
+    "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
+and define JSON->RECORD as a conversion from JSON (from a port, string or alist)
+to a record of this type. Optionally, define RECORD->JSON as a conversion from a
+record of this type to a JSON string. Additionally, define SCM->RECORD as a
+conversion from an alist to a record of this type (equivalent to JSON->RECORD
+when passing an alist) and RECORD->SCM as a conversion from a record of this
+type to an alist."
+    ((_ rtd ctor pred json->record (field getter spec ...) ...)
+     (begin
+       (define-record-type rtd
+         (ctor field ...)
+         pred
+         (field getter) ...)
+
+       (define-json-reader json->record ctor
+         (field spec ...) ...)))
+    ((_ rtd ctor pred json->record <=> record->json (field getter spec ...) ...)
+     (begin
+       (define-record-type rtd
+         (ctor field ...)
+         pred
+         (field getter) ...)
+
+       (define-json-reader json->record ctor
+         (field spec ...) ...)
+
+       (define-json-writer record->json
+         (field getter spec ...) ...)))
+    ((_ rtd ctor pred json->record <=> record->json <=> scm->record <=> record->scm (field getter spec ...) ...)
+     (begin
+       (define-record-type rtd
+         (ctor field ...)
+         pred
+         (field getter) ...)
+
+       (define-json-reader json->record ctor
+         (field spec ...) ...)
+
+       (define-json-writer record->json
+         (field getter spec ...) ...)
+
+       (define-native-reader scm->record ctor
+         (field spec ...) ...)
+
+       (define-native-writer record->scm
+         (field getter spec ...) ...)))))
+
+(define-syntax define-json-type
+  (lambda (x)
+    "Define RTD as a record type with the given FIELDs. This will automatically
+define a record and its constructor, predicate and fields with their getters as
+they would be defined by define-json-mapping."
+    (define (gen-id template-id . args)
+      (datum->syntax
+       template-id
+       (string->symbol
+        (apply string-append
+               (map (lambda (x)
+                      (if (string? x) x (symbol->string (syntax->datum x))))
+                    args)))))
+    (define (cleanup-single-rtd template-id)
+      (datum->syntax
+       template-id
+       (string->symbol
+        (string-delete
+         (lambda (c) (or (eq? c #\<) (eq? c #\>)))
+         (symbol->string (syntax->datum template-id))))))
+    (define (cleanup-vector-rtd template-id)
+      (cleanup-single-rtd (datum->syntax template-id (vector-ref (syntax->datum template-id) 0))))
+
+    (define (cleanup-rtd template-id)
+      (if (vector? (syntax->datum template-id))
+          (cleanup-vector-rtd template-id)
+          (cleanup-single-rtd template-id)))
+    (syntax-case x (<=>)
+      ((_ rtd field ...)
+       (with-syntax ((mapping-rtd #'rtd)
+                     (constructor (gen-id #'rtd "make-" (cleanup-rtd #'rtd)))
+                     (predicate (gen-id #'rtd (cleanup-rtd #'rtd) "?"))
+                     (json->record (gen-id #'rtd "json->" (cleanup-rtd #'rtd)))
+                     (record->json (gen-id #'rtd (cleanup-rtd #'rtd) "->json"))
+                     (scm->record (gen-id #'rtd "scm->" (cleanup-rtd #'rtd)))
+                     (record->scm (gen-id #'rtd (cleanup-rtd #'rtd) "->scm"))
+                     ((fields ...)
+                      (map
+                       (lambda (f)
+                         (syntax-case f ()
+                           ((name)
+                            #`(name #,(gen-id #'rtd (cleanup-rtd #'rtd) "-" #'name)))
+                           ((name key)
+                            #`(name #,(gen-id #'rtd (cleanup-rtd #'rtd) "-" #'name) key))
+                           ((name key field-rtd)
+                            #`(name
+                               #,(gen-id #'rtd (cleanup-rtd #'rtd) "-" #'name)
+                               key
+                               #,(if (vector? (syntax->datum #'field-rtd))
+                                     #`(lambda (v) (if (unspecified? v)
+                                                       *unspecified*
+                                                       (map #,(gen-id #'field-rtd "scm->" (cleanup-rtd #'field-rtd))
+                                                            (vector->list v))))
+                                     #`(lambda (v) (if (unspecified? v)
+                                                       *unspecified*
+                                                       (#,(gen-id #'field-rtd "scm->" (cleanup-rtd #'field-rtd)) v))))
+                               #,(if (vector? (syntax->datum #'field-rtd))
+                                     #`(lambda (v)
+                                         (list->vector
+                                          (map #,(gen-id #'field-rtd (cleanup-rtd #'field-rtd) "->scm") v)))
+                                     (gen-id #'field-rtd (cleanup-rtd #'field-rtd) "->scm" ))))))
+                       #'(field ...))))
+         #'(define-json-mapping mapping-rtd
+             constructor
+             predicate
+             json->record <=> record->json <=> scm->record <=> record->scm
+             fields ...))))))
+
+;;; (json record) ends here

swayipc/connection.scm

@@ -0,0 +1,201 @@
+(define-module (swayipc connection)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 hash-table)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-18)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-1)
+
+  #:export (RUN-COMMMAND-MSG-ID
+            GET-WORKSPACES-MSG-ID
+            SUBSCRIBE-MSG-ID
+            GET-OUTPUTS-MSG-ID
+            GET-TREE-MSG-ID
+            GET-MARKS-MSG-ID
+            GET-BAR-CONFIG-MSG-ID
+            GET-VERSION-MSG-ID
+            GET-BINDING-MODES-MSG-ID
+            GET-CONFIG-MSG-ID
+            SEND-TICK-MSG-ID
+            SYNC-MSG-ID
+            GET-BINDING-STATE-MSG-ID
+            GET-INPUTS-MSG-ID
+            GET-SEATS-MSG-ID
+
+            WORKSPACE-EVENT-REPLY
+            OUTPUT-EVENT-REPLY
+            MODE-EVENT-REPLY
+            WINDOW-EVENT-REPLY
+            BAR-CONFIG-UPDATE-EVENT-REPLY
+            BINDING-EVENT-REPLY
+            SHUTDOWN-EVENT-REPLY
+            TICK-EVENT-REPLY
+            BAR-STATE-UPDATE-EVENT-REPLY
+            INPUT-EVENT-REPLY
+
+            SOCKET-PATH
+            COMMAND-SOCKET
+            LISTENER-SOCKET
+            LISTENER-THREAD
+            MSG-MAGIC
+            MSG-MAGIC-BV
+            start-event-listener-thread
+            start-event-listener
+            data-received-hook
+            command-received-hook
+
+            SOCKET-COMMANDS-LISTENER-PATH
+            COMMANDS-LISTENER-SOCKET
+            COMMANDS-LISTENER-THREAD
+            start-commands-listener-thread
+            start-commands-listener
+
+            write-msg
+            read-msg
+            encode-msg))
+
+;; sway messages and replies types
+;; man: sway-ipc(7): MESSAGES AND REPLIES
+(define RUN-COMMMAND-MSG-ID 0)
+(define GET-WORKSPACES-MSG-ID 1)
+(define SUBSCRIBE-MSG-ID 2)
+(define GET-OUTPUTS-MSG-ID 3)
+(define GET-TREE-MSG-ID 4)
+(define GET-MARKS-MSG-ID 5)
+(define GET-BAR-CONFIG-MSG-ID 6)
+(define GET-VERSION-MSG-ID 7)
+(define GET-BINDING-MODES-MSG-ID 8)
+(define GET-CONFIG-MSG-ID 9)
+(define SEND-TICK-MSG-ID 10)
+(define SYNC-MSG-ID 11)
+(define GET-BINDING-STATE-MSG-ID 12)
+(define GET-INPUTS-MSG-ID 100)
+(define GET-SEATS-MSG-ID 101)
+
+(define WORKSPACE-EVENT-REPLY 2147483648)
+(define OUTPUT-EVENT-REPLY 2147483649)
+(define MODE-EVENT-REPLY 2147483650)
+(define WINDOW-EVENT-REPLY 2147483651)
+(define BAR-CONFIG-UPDATE-EVENT-REPLY 2147483652)
+(define BINDING-EVENT-REPLY 2147483653)
+(define SHUTDOWN-EVENT-REPLY 2147483654)
+(define TICK-EVENT-REPLY 2147483655)
+(define BAR-STATE-UPDATE-EVENT-REPLY 2147483656)
+(define INPUT-EVENT-REPLY 2147483657)
+
+(define LISTENER-THREAD #:f)
+(define COMMANDS-LISTENER-THREAD #:f)
+(define MSG-MAGIC "i3-ipc")
+(define MSG-MAGIC-BV (string->utf8 MSG-MAGIC))
+
+;; TODO: maybe also get from sway and i3 binaries
+(define SOCKET-PATH
+  (and (getenv "SWAYSOCK")
+       (getenv "I3SOCK")))
+
+(define SOCKET-COMMANDS-LISTENER-PATH
+  (string-append (dirname SOCKET-PATH) "/sway-commands-ipc.sock"))
+
+(define COMMAND-SOCKET (socket AF_UNIX SOCK_STREAM 0))
+(connect COMMAND-SOCKET (make-socket-address AF_UNIX SOCKET-PATH))
+(define LISTENER-SOCKET (socket AF_UNIX SOCK_STREAM 0))
+(connect LISTENER-SOCKET (make-socket-address AF_UNIX SOCKET-PATH))
+(define COMMANDS-LISTENER-SOCKET (socket AF_UNIX SOCK_STREAM 0))
+
+;; <magic-string> is i3-ipc, for compatibility with i3
+;; <payload-length> is a 32-bit integer in native byte order
+;; <payload-type> is a 32-bit integer in native byte order
+(define (encode-msg command-id payload)
+  (let* ((bv (make-bytevector (+ 14 (string-length payload)))))
+    ;; <magic-string> <payload-length> <payload-type> <payload>
+    (bytevector-copy! (string->utf8 "i3-ipc") 0 bv 0 6)
+    (bytevector-u32-set! bv 6 (string-length payload) (native-endianness))
+    (bytevector-u32-set! bv 10 command-id (native-endianness))
+
+    ;; payload is optional
+    (when (> (string-length payload) 0)
+      (bytevector-copy! (string->utf8 payload) 0 bv 14 (string-length payload)))
+    bv))
+
+(define (write-msg sock command-id payload)
+  (put-bytevector sock (encode-msg command-id payload)))
+
+;; Mutex for synchronization
+(define mutex-table (make-hash-table))
+
+(define (read-msg sock)
+  (let* ((mutex (if (hash-get-handle mutex-table (fileno sock))
+                    (cdr (hash-get-handle mutex-table (fileno sock)))
+                    (hash-set! mutex-table (fileno sock) (make-mutex)))))
+    (mutex-lock! mutex)
+    (let* ((bv-header (get-bytevector-n sock 14))
+          (payload-length (bytevector-u32-ref bv-header 6 (native-endianness)))
+          (command-id (bytevector-u32-ref bv-header 10 (native-endianness)))
+          (payload (utf8->string (get-bytevector-n sock payload-length))))
+      (mutex-unlock! mutex)
+      (list command-id (or payload "")))))
+
+(define (read-from-socket sock)
+  (let loop ()
+      (let ((data (read-msg sock)))
+        (run-hook data-received-hook
+                  (list-ref data 0)
+                  (list-ref data 1))
+              (loop))))
+
+(define data-received-hook
+  ;; data received: emitted on new data received via ipc.
+
+  ;; Parameters:
+  ;;   - arg1: command-id.
+  ;;   - arg2: payload.
+  (make-hook 2))
+
+(define command-received-hook
+  ;; data received: emitted on new command received via ipc.
+
+  ;; Parameters:
+  ;;   - arg1: command-id.
+  ;;   - arg2: payload.
+  (make-hook 2))
+
+(define (handle-client client)
+  (let ((port (car client)))
+    (let ((data (read-msg port)))
+      (run-hook command-received-hook
+                (list-ref data 0)
+                (list-ref data 1)))
+
+    ;; Close the connection
+    (close-port port)))
+
+(define (custom-exception-handler exc)
+  (display "An error occurred while handling client connection\n"))
+
+(define (start-server-socket sock)
+  (listen sock 15)
+  (let loop ()
+    (let ((client (accept sock)))
+      (handle-client client)
+      (loop))))
+
+(define (start-event-listener)
+  (read-from-socket LISTENER-SOCKET))
+
+(define (start-event-listener-thread)
+  (set! LISTENER-THREAD (make-thread start-event-listener))
+  (thread-start! LISTENER-THREAD))
+
+(define (start-commands-listener)
+  (when (file-exists? SOCKET-COMMANDS-LISTENER-PATH)
+    (delete-file SOCKET-COMMANDS-LISTENER-PATH))
+
+  (bind COMMANDS-LISTENER-SOCKET (make-socket-address AF_UNIX SOCKET-COMMANDS-LISTENER-PATH))
+  (start-server-socket COMMANDS-LISTENER-SOCKET))
+
+(define (start-commands-listener-thread)
+  (set! COMMANDS-LISTENER-THREAD (make-thread start-commands-listener))
+  (thread-start! COMMANDS-LISTENER-THREAD))

swayipc/events.scm

@@ -0,0 +1,173 @@
+(define-module (swayipc events)
+  #:use-module (swayipc connection)
+  #:use-module (swayipc records)
+
+  #:export (sway-subscribe-event
+            sway-subscribe-workspace-change
+            sway-subscribe-workspace-event
+            sway-subscribe-output-event
+            sway-subscribe-binding-mode-event
+            sway-subscribe-window-event
+            sway-subscribe-barconfig-update-event
+            sway-subscribe-binding-event
+            sway-subscribe-shutdown-event
+            sway-subscribe-tick-event
+            sway-subscribe-bar-state-event
+            sway-subscribe-input-event
+            sway-subscribe-all
+
+            sway-workspace-hook
+            sway-output-hook
+            sway-mode-hook
+            sway-window-hook
+            sway-bar-config-hook
+            sway-shutdown-hook
+            sway-tick-hook
+            sway-bar-state-update-hook
+            sway-input-hook))
+
+(define (sway-subscribe-event event)
+  "A client can subscribe to any events it wants to be notified of changes for."
+  (write-msg LISTENER-SOCKET SUBSCRIBE-MSG-ID event)
+  (json->sway-tick (list-ref (read-msg LISTENER-SOCKET) 1)))
+
+(define (sway-subscribe-workspace-event)
+  "Sent whenever an event involving a workspace occurs such as initialization
+   of a new workspace or a different workspace gains focus."
+  (sway-subscribe-event "['workspace']"))
+
+(define (sway-subscribe-output-event)
+  "Sent when outputs are updated."
+  (sway-subscribe-event "['output']"))
+
+(define (sway-subscribe-binding-mode-event)
+  "Sent whenever the binding mode changes."
+  (sway-subscribe-event "['mode']"))
+
+(define (sway-subscribe-window-event)
+ "Sent whenever an event involving a view occurs such as being reparented, focused, or closed."
+  (sway-subscribe-event "['window']"))
+
+(define (sway-subscribe-barconfig-update-event)
+ "Sent whenever a bar config changes."
+  (sway-subscribe-event "['barconfig_update']"))
+
+(define (sway-subscribe-binding-event)
+  "Sent when a configured binding is executed." 
+  (sway-subscribe-event "['binding']"))
+
+(define (sway-subscribe-shutdown-event)
+ "Sent when the ipc shuts down because sway is exiting." 
+  (sway-subscribe-event "['shutdown']"))
+
+(define (sway-subscribe-tick-event)
+  "Sent when an ipc client sends a SEND_TICK message."
+  (sway-subscribe-event "['tick']"))
+
+(define (sway-subscribe-bar-state-event)
+  "Send when the visibility of a bar should change due to a modifier."
+  (sway-subscribe-event "['bar_state_update']"))
+
+(define (sway-subscribe-input-event)
+  "Sent when something related to input devices changes."
+  (sway-subscribe-event "['input']"))
+
+(define (sway-subscribe-all)
+  "subscribe to all available events."
+  (sway-subscribe-event "['workspace', 'output', 'mode', 'window', 'barconfig_update',
+	'binding', 'shutdown', 'tick', 'bar_state_update', 'input']"))
+
+(define (custom-exception-handler exc command-id payload)
+  (display "An error occurred while receiving event data\n")
+  (display (string-append "command: " (number->string command-id) ", payload: " payload)))
+
+(add-hook! data-received-hook
+           (lambda (command-id payload)
+             (with-exception-handler
+              (lambda (exc)
+                (custom-exception-handler exc command-id payload))
+               (lambda () (handle-event command-id payload))
+               #:unwind? #t)))
+
+(define (handle-event command-id payload)
+  (cond
+   ((= command-id WORKSPACE-EVENT-REPLY)
+    (run-hook sway-workspace-hook (json->sway-workspace-event payload)))
+   ((= command-id OUTPUT-EVENT-REPLY)
+    (run-hook sway-output-hook (json->sway-output-event payload)))
+   ((= command-id MODE-EVENT-REPLY)
+    (run-hook sway-mode-hook (json->sway-mode-event payload)))
+   ((= command-id WINDOW-EVENT-REPLY)
+    (run-hook sway-window-hook (json->sway-window-event payload)))
+   ((= command-id BAR-CONFIG-UPDATE-EVENT-REPLY)
+    (run-hook sway-bar-config-hook (json->sway-bar-config payload)))
+   ((= command-id BINDING-EVENT-REPLY)
+    (run-hook sway-binding-hook (json->sway-binding-event payload)))
+   ((= command-id SHUTDOWN-EVENT-REPLY)
+    (run-hook sway-shutdown-hook (json->sway-shutdown-event payload)))
+   ((= command-id TICK-EVENT-REPLY)
+    (run-hook sway-tick-hook (json->sway-tick-event payload)))
+   ((= command-id BAR-STATE-UPDATE-EVENT-REPLY)
+    (run-hook sway-bar-state-update-hook (json->sway-bar-state-update-event payload)))
+   ((= command-id INPUT-EVENT-REPLY)
+    (run-hook sway-input-hook (json->sway-input-event payload)))))
+
+(define sway-workspace-hook
+  ;; workspace changed: emitted on workspace change.
+  ;; Parameters:
+  ;;   - arg1: sway-workspace-event.
+  (make-hook 1))
+
+(define sway-output-hook
+  ;; output changed: emitted on output change.
+  ;; Parameters:
+  ;;   - arg1: sway-output-event.
+  (make-hook 1))
+
+(define sway-mode-hook
+  ;; mode changed: emitted on mode change.
+  ;; Parameters:
+  ;;   - arg1: sway-mode-event.
+  (make-hook 1))
+
+(define sway-window-hook
+  ;; window changed: emitted on window change.
+  ;; Parameters:
+  ;;   - arg1: sway-window-event.
+  (make-hook 1))
+
+(define sway-binding-hook
+  ;; binding changed: emitted on binding change.
+  ;; Parameters:
+  ;;   - arg1: sway-binding-event.
+  (make-hook 1))
+
+(define sway-bar-config-hook
+  ;; bar-config changed: emitted on bar-config change.
+  ;; Parameters:
+  ;;   - arg1: sway-bar-config-event.
+  (make-hook 1))
+
+(define sway-shutdown-hook
+  ;; shutdown changed: emitted on shutdown change.
+  ;; Parameters:
+  ;;   - arg1: sway-shutdown-event.
+  (make-hook 1))
+
+(define sway-tick-hook
+  ;; tick changed: emitted on tick change.
+  ;; Parameters:
+  ;;   - arg1: sway-tick-event.
+  (make-hook 1))
+
+(define sway-bar-state-update-hook
+  ;; bar-state-update changed: emitted on bar-state-update change.
+  ;; Parameters:
+  ;;   - arg1: sway-bar-state-update-event.
+  (make-hook 1))
+
+(define sway-input-hook
+  ;; input changed: emitted on input change.
+  ;; Parameters:
+  ;;   - arg1: sway-input-event.
+  (make-hook 1))

swayipc/info.scm

@@ -0,0 +1,113 @@
+(define-module (swayipc info)
+  #:use-module (swayipc connection)
+  #:use-module (swayipc records)
+  #:use-module (oop goops)
+  #:use-module (sjson parser)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-1)
+
+  #:export (sway-get-workspaces
+            sway-get-outputs
+            sway-get-tree
+            sway-get-marks
+            sway-get-bars
+            sway-get-bar-config
+            sway-get-version
+            sway-get-binding-modes
+            sway-get-config
+            sway-get-binding-state
+            sway-get-inputs
+            sway-get-seats))
+
+(define (custom-exception-handler exc command-id payload)
+  (display "An error occurred: ")
+  (display (exp->string exc))
+  (newline)
+  (display (string-append "command: " (number->string command-id) ", payload: " payload)))
+
+(define (sway-send-query message-id payload)
+  "returns the ipc response from sway after sending the message-id and payload"
+  (with-exception-handler
+              (lambda (exc)
+                (custom-exception-handler exc command-id payload))
+               (lambda () (begin
+                            (write-msg COMMAND-SOCKET
+                                      message-id
+                                      payload)
+                            (let* ((out (read-msg COMMAND-SOCKET)))
+                              (list-ref out 1))))
+               #:unwind? #t))
+
+(define (sway-get-workspaces)
+  "Retrieves the list of workspaces."
+  (map
+    (lambda (workspace)
+      (scm->sway-workspace workspace))
+    (vector->list
+     (json-string->scm
+      (sway-send-query GET-WORKSPACES-MSG-ID "")))))
+
+(define (sway-get-outputs)
+  "Retrieve the list of outputs."
+  (map
+    (lambda (output)
+      (scm->sway-output output))
+    (vector->list
+     (json-string->scm
+      (sway-send-query GET-OUTPUTS-MSG-ID "")))))
+
+(define (sway-get-tree)
+  "Retrieve a representation of the tree."
+  (json->sway-tree (sway-send-query GET-TREE-MSG-ID "")))
+
+(define (sway-get-marks)
+  "Retrieve the currently set marks."
+  (vector->list
+     (json-string->scm
+      (sway-send-query GET-MARKS-MSG-ID ""))))
+
+(define (sway-get-bars)
+  "retrieves the list of configured bar IDs."
+  (vector->list
+     (json-string->scm
+      (sway-send-query GET-BAR-CONFIG-MSG-ID ""))))
+
+(define (sway-get-bar-config bar-id)
+  "retrieves the config associated with the specified by the bar ID."
+  (json->sway-bar-config (sway-send-query GET-BAR-CONFIG-MSG-ID bar-id)))
+
+(define (sway-get-version)
+  "Retrieve version information about the sway process."
+  (json->sway-version (sway-send-query GET-VERSION-MSG-ID "")))
+
+(define (sway-get-binding-modes)
+  "Retrieve the list of binding modes that currently configured."
+  (vector->list
+     (json-string->scm
+      (sway-send-query GET-BINDING-MODES-MSG-ID ""))))
+
+(define (sway-get-config)
+  "Retrieve the list of binding modes that currently configured."
+  (json->sway-config (sway-send-query GET-CONFIG-MSG-ID "")))
+
+(define (sway-get-binding-state)
+  "Returns the currently active binding mode."
+  (json->sway-binding-state (sway-send-query GET-BINDING-STATE-MSG-ID "")))
+
+(define (sway-get-inputs)
+  "Retrieve a list of the input devices currently available."
+  (map
+      (lambda (input)
+        (scm->sway-input input))
+      (vector->list
+      (json-string->scm
+        (sway-send-query GET-INPUTS-MSG-ID "")))))
+
+(define (sway-get-seats)
+  "Retrieve a list of the seats currently configured."
+  (map
+      (lambda (seat)
+        (scm->sway-seat seat))
+      (vector->list
+      (json-string->scm
+        (sway-send-query GET-SEATS-MSG-ID "")))))

swayipc/records.scm

@@ -0,0 +1,491 @@
+(define-module (swayipc records)
+  #:use-module (oop goops)
+  #:use-module (sjson record)
+  #:use-module (sjson parser)
+  #:use-module (sjson builder)
+
+  #:export (<sway-rect>
+            scm->sway-rect
+            json->sway-rect
+            sway-rect-x
+            sway-rect-y
+            sway-rect-width
+            sway-rect-height
+
+            <sway-workspace>
+            scm->sway-workspace
+            json->sway-workspace
+            sway-workspace-num
+            sway-workspace-name
+            sway-workspace-visible
+            sway-workspace-focused
+            sway-workspace-urgent
+            sway-workspace-rect
+            sway-workspace-output
+
+            <sway-mode>
+            scm->sway-mode
+            json->sway-mode
+            sway-mode-width
+            sway-mode-height
+            sway-mode-refresh
+            sway-mode-picture-aspect-ratio
+
+            <sway-output>
+            scm->sway-output
+            json->sway-output
+            sway-output-name
+            sway-output-make
+            sway-output-model
+            sway-output-serial
+            sway-output-active
+            sway-output-primary
+            sway-output-scale
+            sway-output-subpixel-hinting
+            sway-output-transform
+            sway-output-current-workspace
+            sway-output-modes
+            sway-output-current-mode
+
+            <sway-window-property>
+            scm->sway-window-property
+            json->sway-window-property
+            class
+            instance
+            title
+            transient-for
+
+            <sway-tree>
+            scm->sway-tree
+            json->sway-tree
+            sway-tree-id
+            sway-tree-name
+            sway-tree-type
+            sway-tree-border
+            sway-tree-current-border-width
+            sway-tree-layout
+            sway-tree-orientation
+            sway-tree-percent
+            sway-tree-rect
+            sway-tree-window-rect
+            sway-tree-deco-rect
+            sway-tree-geometry
+            sway-tree-urgent
+            sway-tree-sticky
+            sway-tree-marks
+            sway-tree-focused
+            sway-tree-focus
+            sway-tree-nodes
+            sway-tree-floating-nodes
+            sway-tree-representation
+            sway-tree-fullscreen-mode
+            sway-tree-app-id
+            sway-tree-pid
+            sway-tree-visible
+            sway-tree-shell
+            sway-tree-inhibit-idle
+            sway-tree-idle-inhibitors
+            sway-tree-window
+            sway-tree-window-properties
+
+            <sway-bar-color>
+            scm->sway-bar-color
+            json->sway-bar-color
+            sway-bar-color-background
+            sway-bar-color-status-line
+            sway-bar-color-separator
+            sway-bar-color-focused-background
+            sway-bar-color-focused-statusline
+            sway-bar-color-focused-separator
+            sway-bar-color-focused-workspace-text
+            sway-bar-color-focused-workspace-background
+            sway-bar-color-focused-workspace-border
+            sway-bar-color-active-workspace-text
+            sway-bar-color-active-workspace-background
+            sway-bar-color-active-workspace-border
+            sway-bar-color-inactive-workspace-text
+            sway-bar-color-inactive-workspace-background
+            sway-bar-color-inactive-workspace-border
+            sway-bar-color-urgent-workspace-text
+            sway-bar-color-urgent-workspace-background
+            sway-bar-color-urgent-workspace-border
+            sway-bar-color-binding-mode-text
+            sway-bar-color-binding-mode-background
+            sway-bar-color-binding-mode-border
+
+            <sway-bar-gap>
+            scm->sway-bar-gap
+            json->sway-bar-gap
+            sway-bar-gap-top
+            sway-bar-gap-right
+            sway-bar-gap-bottom
+            sway-bar-gap-left
+
+            <sway-bar-config>
+            scm->sway-bar-config
+            json->sway-bar-config
+            sway-bar-config-id
+            sway-bar-config-mode
+            sway-bar-config-position
+            sway-bar-config-status-command
+            sway-bar-config-font
+            sway-bar-config-workspace-buttons
+            sway-bar-config-workspace-min-width
+            sway-bar-config-binding-mode-indicator
+            sway-bar-config-verbose
+            sway-bar-config-colors
+            sway-bar-config-gaps
+            sway-bar-config-bar-height
+            sway-bar-config-status-padding
+            sway-bar-config-status-edge-padding
+
+            <sway-version>
+            scm->sway-version
+            json->sway-version
+            sway-version-major
+            sway-version-minor
+            sway-version-patch
+            sway-version-human-readable
+            sway-version-loaded-config-file-name
+
+            <sway-config>
+            scm->sway-config
+            json->sway-config
+            sway-config-config
+
+            <sway-tick>
+            scm->sway-tick
+            json->sway-tick
+            sway-tick-success
+            sway-tick-parse-error
+            sway-tick-error
+
+            <sway-sync>
+            scm->sway-sync
+            json->sway-sync
+            sway-sync-success
+
+            <sway-binding-state>
+            scm->sway-binding-state
+            json->sway-binding-state
+            sway-binding-state-name
+
+            <sway-lib-input>
+            scm->sway-lib-input
+            json->sway-lib-input
+            sway-lib-input-send-events
+            sway-lib-input-tap
+            sway-lib-input-tap-button-map
+            sway-lib-input-tap-drag
+            sway-lib-input-tap-drag-lock
+            sway-lib-input-accel-speed
+            sway-lib-input-accel-profile
+            sway-lib-input-natural-scroll
+            sway-lib-input-left-handed
+            sway-lib-input-click-method
+            sway-lib-input-middle-emulation
+            sway-lib-input-scroll-method
+            sway-lib-input-scroll-button
+            sway-lib-input-scroll-button-lock
+            sway-lib-input-dwt
+            sway-lib-input-dwtp
+            sway-lib-input-calibration-matrix
+
+            <sway-input>
+            scm->sway-input
+            json->sway-input
+            sway-input-identifier
+            sway-input-name
+            sway-input-vendor
+            sway-input-product
+            sway-input-type
+            sway-input-xkb-active-layout-name
+            sway-input-xkb-layout-names
+            sway-input-scroll-factor
+            sway-input-libinput
+
+            <sway-seat>
+            scm->sway-seat
+            json->sway-seat
+            sway-seat-name
+            sway-seat-capabilities
+            sway-seat-focus
+            sway-seat-devices
+
+            <sway-workspace-event>
+            scm->sway-workspace-event
+            json->sway-workspace-event
+            sway-workspace-event-change
+            sway-workspace-event-old
+            sway-workspace-event-current
+
+            <sway-output-event>
+            scm->sway-output-event
+            json->sway-output-event
+            sway-output-event-change
+
+            <sway-mode-event>
+            scm->sway-mode-event
+            json->sway-mode-event
+            sway-mode-event-change
+            sway-mode-event-pango-markup
+
+            <sway-window-event>
+            scm->sway-window-event
+            json->sway-window-event
+            sway-window-event-change
+            sway-window-event-container
+
+            <sway-binding-event>
+            scm->sway-binding-event
+            json->sway-binding-event
+            sway-binding-event-change
+            sway-binding-event-binding
+
+            <sway-binding-event-binding>
+            scm->sway-binding-event-binding
+            json->sway-binding-event-binding
+            sway-binding-event-binding-command
+            sway-binding-event-binding-event-state-mask
+            sway-binding-event-binding-input-code
+            sway-binding-event-binding-sybmol
+            sway-binding-event-binding-input-type
+
+            <sway-shutdown-event>
+            scm->sway-shutdown-event
+            json->sway-shutdown-event
+            sway-shutdown-event-change
+
+            <sway-tick-event>
+            scm->sway-tick-event
+            json->sway-tick-event
+            sway-tick-event-first
+            sway-tick-event-paylaod
+
+            <sway-bar-state-update-event>
+            scm->sway-bar-state-update-event
+            json->sway-bar-state-update-event
+            sway-bar-state-update-event-id
+            sway-bar-state-update-event-visible-by-modifier
+
+            <sway-input-event>
+            scm->sway-input-event
+            json->sway-input-event
+            sway-input-event-change
+            sway-input-event-input))
+
+(define-json-type <sway-rect>
+  (x)
+  (y)
+  (width)
+  (height))
+
+(define-json-type <sway-workspace>
+  (num)
+  (name)
+  (visible)
+  (focused)
+  (urgent)
+  (rect "rect" <sway-rect>)
+  (output))
+
+(define-json-type <sway-mode>
+  (picture-aspect-ratio "picture_aspect_ratio")
+  (refresh)
+  (height)
+  (width))
+
+(define-json-type <sway-output>
+  (name)
+  (make)
+  (model)
+  (serial)
+  (active)
+  (primary)
+  (scale)
+  (subpixel-hinting "subpixel_hinting")
+  (transform)
+  (current-workspace "current_workspace")
+  (modes "modes" #(<sway-mode>))
+  (current-mode "current_mode" <sway-mode>))
+
+(define-json-type <sway-window-property>
+  (class)
+  (instance)
+  (title)
+  (transient-for "transient_for"))
+
+(define-json-type <sway-tree>
+  (id)
+  (name)
+  (type)
+  (border)
+  (current-border-width "current_border_width")
+  (layout)
+  (orientation)
+  (percent)
+  (rect "rect" <sway-rect>)
+  (window-rect "window_rect" <sway-rect>)
+  (deco-rect "deco_rect" <sway-rect>)
+  (geometry "geometry" <sway-rect>)
+  (urgent)
+  (sticky)
+  (marks)
+  (focused)
+  (focus)
+  (nodes "nodes" #(<sway-tree>))
+  (floating-nodes "floating_nodes" #(<sway-tree>))
+  (representation)
+  (fullscreen-mode "fullscreen_mode")
+  (app-id "app_id")
+  (pid)
+  (visible)
+  (shell)
+  (inhibit-idle "inhibit_idle")
+  (idle-inhibitors "idle_inhibitors")
+  (window)
+  (window-properties "window_properties" <sway-window-property>))
+
+(define-json-type <sway-bar-color>
+  (background)
+  (status-line "statusline")
+  (separator)
+  (focused-background "focused_background")
+  (focused-statusline "focused_statusline")
+  (focused-separator "focused_separator")
+  (focused-workspace-text "focused_workspace_text")
+  (focused-workspace-background "focused_workspace_bg")
+  (focused-workspace-border "focused_workspace_border")
+  (active-workspace-text "active_workspace_text")
+  (active-workspace-background "active_workspace_bg")
+  (active-workspace-border "active_workspace_border")
+  (inactive-workspace-text "inactive_workspace_text")
+  (inactive-workspace-background "inactive_workspace_bg")
+  (inactive-workspace-border "inactive_workspace_border")
+  (urgent-workspace-text "urgent_workspace_text")
+  (urgent-workspace-background "urgent_workspace_bg")
+  (urgent-workspace-border "urgent_workspace_border")
+  (binding-mode-text "binding_mode_text")
+  (binding-mode-background "binding_mode_bg")
+  (binding-mode-border "binding_mode_border"))
+
+(define-json-type <sway-bar-gap>
+  (top)
+  (right)
+  (bottom)
+  (left))
+
+(define-json-type <sway-bar-config>
+  (id)
+  (mode)
+  (position)
+  (status-command "status_command")
+  (font)
+  (workspace-buttons "workspace_buttons")
+  (workspace-min-width "workspace_min_width")
+  (binding-mode-indicator)
+  (verbose)
+  (colors "colors" <sway-bar-color>)
+  (gaps "gaps" <sway-bar-gap>)
+  (bar-height "bar_height")
+  (status-padding "status_padding")
+  (status-edge-padding "status_edge_padding"))
+
+(define-json-type <sway-version>
+  (major)
+  (minor)
+  (patch)
+  (human-readable "human_readable")
+  (loaded-config-file-name "loaded_config_file_name"))
+
+(define-json-type <sway-config>
+  (config))
+
+(define-json-type <sway-tick>
+  (success)
+  (parse-error "parse_error")
+  (error))
+
+(define-json-type <sway-sync>
+  (success))
+
+(define-json-type <sway-binding-state>
+  (name))
+
+(define-json-type <sway-lib-input>
+  (send-events "send_events")
+  (tap)
+  (tap-button-map "tap_button_map")
+  (tap-drag "tap_drag")
+  (tap-drag-lock "tap_drag_lock")
+  (accel-speed "accel_speed")
+  (accel-profile "accel_profile")
+  (natural-scroll "natural_scroll")
+  (left-handed "left_handed")
+  (click-method "click_method")
+  (middle-emulation "middle_emulation")
+  (scroll-method "scroll_method")
+  (scroll-button "scroll_button")
+  (scroll-button-lock "scroll_button_lock")
+  (dwt)
+  (dwtp)
+  (calibration-matrix "calibration_matrix"))
+
+(define-json-type <sway-input>
+  (identifier)
+  (name)
+  (vendor)
+  (product)
+  (type)
+  (xkb-active-layout-name "xkb_active_layout_name")
+  (xkb-layout-names "xkb_layout_names")
+  (scroll-factor "scroll_factor")
+  (libinput <sway-lib-input>))
+
+(define-json-type <sway-seat>
+  (name)
+  (capabilities)
+  (focus)
+  (devices "devices" #(<sway-input>)))
+
+(define-json-type <sway-workspace-event>
+  (change)
+  (old "old" <sway-tree>)
+  (current "current" <sway-tree>))
+
+(define-json-type <sway-output-event>
+  (change))
+
+(define-json-type <sway-mode-event>
+  (change)
+  (pango-markup "pango_markup"))
+
+(define-json-type <sway-window-event>
+  (change)
+  (container "container" <sway-tree))
+
+(define-json-type <sway-binding-event>
+  (change)
+  (binding "binding" <sway-binding-event-binding))
+
+(define-json-type <sway-binding-event-binding>
+  (command)
+  (event-state-mask "event_state_mask")
+  (input-code "input_code")
+  (sybmol)
+  (input-type "input_type"))
+
+(define-json-type <sway-shutdown-event>
+  (change))
+
+(define-json-type <sway-tick-event>
+  (first)
+  (paylaod))
+
+(define-json-type <sway-bar-state-update-event>
+  (id)
+  (visible-by-modifier "visible_by_modifier"))
+
+(define-json-type <sway-input-event>
+  (change)
+  (input "input" <sway-lib-input>))