Miroirs/guile-swayer
1
0
Fork 0
mirror of https://github.com/ebeem/guile-swayer.git synced 2024-12-24 21:58:56 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

init commit

Browse source
This commit is contained in:
Almarhoon Ibraheem 2024-06-15 10:57:11 +03:00
commit 5a866ddf1c
20 changed files with 6345 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

127
README.org Normal file
View file

@ -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

9
behavior.scm Executable file
View file

@ -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)

39
commander Executable file
View file

@ -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) " ")))

2
config Normal file
View file

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

51
init.scm Executable file
View file

@ -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)

122
keybindings.scm Executable file
View file

@ -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)))))

4
modules/auto-reload.scm Executable file
View file

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

124
modules/general.scm Executable file
View file

@ -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))))

2113
modules/kbd.scm Executable file
View file

File diff suppressed because it is too large Load diff

4
modules/which-key.scm Executable file
View file

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

167
modules/workspace-grid.scm Executable file
View file

@ -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"))))

110
modules/workspace-groups.scm Executable file
View file

@ -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))

280
sjson/builder.scm Normal file
View file

@ -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

490
sjson/parser.scm Normal file
View file

@ -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

230
sjson/record.scm Normal file
View file

@ -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

201
swayipc/connection.scm Executable file
View file

@ -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))

1495
swayipc/dispatcher.scm Normal file
View file

File diff suppressed because it is too large Load diff

173
swayipc/events.scm Executable file
View file

@ -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))

113
swayipc/info.scm Executable file
View file

@ -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 "")))))

491
swayipc/records.scm Executable file
View file

@ -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>))