diff options
Diffstat (limited to 'config-generation/sway.sld')
| -rw-r--r-- | config-generation/sway.sld | 193 |
1 files changed, 193 insertions, 0 deletions
diff --git a/config-generation/sway.sld b/config-generation/sway.sld new file mode 100644 index 0000000..6956f0a --- /dev/null +++ b/config-generation/sway.sld @@ -0,0 +1,193 @@ +(define-library (config-generation sway) + (import (scheme base) + (scheme write)) + (export ;;sway-config + scm->sway-config) + (cond-expand + (guile (import (ice-9 match)))) + (cond-expand + ((not chibi) + (import (srfi 13)))) + (cond-expand + ((not guile) (import (srfi 0)))) + (begin + ;; (cond-expand + ;; (chibi + ;; (define (string-join ls . options) + ;; (let ((delimiter (if (> (length options) 0) (car options) " ")) + ;; (grammer (if (> (length options) 1) (cadr options) 'infix))) + ;; (if (pair? ls) + ;; (string-append + ;; (if (equal? grammer 'prefix) delimiter "") + ;; (car ls) + ;; (if (or (equal? grammer 'suffix) + ;; (and (equal? grammer 'infix) + ;; (pair? (cdr ls)))) + ;; delimiter + ;; "") + ;; (if (pair? (cdr ls)) + ;; (string-join (cdr ls) delimiter grammer) + ;; "")) + ;; "")))) + ;; (else)) + + ;; (define-syntax make-string-from-ellipsis + ;; (syntax-rules () + ;; ((_ text ...) + ;; (string-join (map (lambda (x) + ;; (cond + ;; ((string? x) (string-append "\"" x "\"")) + ;; ((symbol? x) (symbol->string x)) + ;; ((number? x) (number->string x)) + ;; (else x))) + ;; '(text ...)))))) + + ;; (define-syntax sway-config + ;; (syntax-rules (bindsyms bindsym set for-window) + ;; ;; Support binding group extension + ;; ((_ (bindsyms (binding ...) ...) lines ...) + ;; (string-append + ;; (sway-config (bindsym binding ...) ...) + ;; (sway-config lines) ...)) + + ;; ;; Support multi-binding extension + ;; ((_ (bindsym (shortcut ...) . action) lines ...) + ;; (string-append + ;; (sway-config (bindsym shortcut . action) ...) + ;; (sway-config lines) ...)) + ;; ((_ (bindsym shortcut (actions ...) ...) lines ...) + ;; (string-append + ;; "bindsym " (symbol->string 'shortcut) " " + ;; (string-join + ;; (map + ;; (lambda (ls) + ;; (string-join + ;; (map + ;; (lambda (x) + ;; (cond + ;; ((symbol? x) (symbol->string x)) + ;; ((number? x) (number->string x)) + ;; (else x))) + ;; ls))) + ;; '((actions ...) ...)) + ;; "; ") + ;; "\n" + ;; (sway-config lines) ...)) + ;; ((_ (bindsym shortcut action ...) lines ...) + ;; (string-append + ;; "bindsym " (make-string-from-ellipsis shortcut action ...) "\n" + ;; (sway-config lines) ...)) + + ;; ;; for_window support + ;; ((_ (for-window (criteria ...) command ...) lines ...) + ;; (letrec-syntax ((criteria->string + ;; (syntax-rules ::: () + ;; ((_ attribute value rest :::) + ;; (string-append " ["(symbol->string 'attribute) "=" "\"" value "\"] " (criteria->string rest :::))) + ;; ((_) "")))) + ;; (string-append + ;; "for_window" (criteria->string criteria ...) (make-string-from-ellipsis command ...) "\n" + ;; (sway-config lines) ...))) + + ;; ;; Support blocks (such as for mode definitions like resize mode) + ;; ((_ (block-start ... (block-body ...))) + ;; (string-append + ;; (make-string-from-ellipsis block-start ...) " {\n" + ;; (sway-config block-body ...) + ;; "}\n")) + + ;; ;; set block + ;; ((_ (set variables ...) lines ...) + ;; (letrec-syntax ((aux (syntax-rules () + ;; ((_ var val . rest) + ;; (string-append + ;; "set " (make-string-from-ellipsis var val) "\n" + ;; (aux . rest))) + ;; ((_) "")))) + ;; (string-append (aux variables ...) + ;; (sway-config lines ...)))) + + ;; ;; Default parsing + ;; ((_ (line ...)) + ;; (string-append (make-string-from-ellipsis line ...) "\n")) + ;; ((_ line lines ...) + ;; (string-append + ;; (sway-config line) + ;; (sway-config lines ...))))) + + (define (scm->sway-config scm) + (define (ensure-string s) + (cond + ((string? s) (string-append "\"" s "\"")) + ((symbol? s) (symbol->string s)) + ((number? s) (number->string s)))) + + (define (plist->list-of-lists pl) + (if (null? pl) + '() + (cons (list (car pl) (cadr pl)) + (plist->list-of-lists (cddr pl))))) + + (match scm + ;; Base case + (() "") + ;; Support binding group extension + ((('bindsyms (bindings ...) ...) . lines) + (string-append + (scm->sway-config (map (lambda (b) (cons 'bindsym b)) bindings)) + (scm->sway-config lines))) + ;; Support multi-binding extension + ((('bindsym (shortcuts ...) action ...) . lines) + (string-append + (apply string-append + (map (lambda (s) + (string-append "bindsym " + (ensure-string s) + " " + (string-join (map ensure-string action)) + "\n")) + shortcuts)) + (scm->sway-config lines))) + ;; Support bindings with multiple actions (not an extension) + ((('bindsym shortcut (actions ...) ...) . lines) + (string-append + "bindsym " (ensure-string shortcut) " " + (string-join + (map + (lambda (ls) + (string-join (map ensure-string ls))) + actions) + "; ") + "\n" + (scm->sway-config lines))) + ;; for_window support + ((('for-window (criteria ...) command ...) . lines) + (let ((criteria->string + (lambda (c) + (string-append " [" (ensure-string (car c)) "=" (ensure-string (cadr c)) "] " )))) + (string-append + "for_window" + (criteria->string criteria) + (string-join (map ensure-string command)) + "\n" + (scm->sway-config lines)))) + ;; Support blocks (such as for mode definitions like resize mode) + (((block-start ... (block-body ...)) . lines) + (string-append + (string-join (map ensure-string block-start)) " {\n" + (scm->sway-config block-body) + "}\n" + (scm->sway-config lines))) + ;; set block + ((('set . variables) . lines) + (apply string-append + (append + (map (lambda (v) (string-join (list "set" (scm->sway-config (list v))))) + (plist->list-of-lists variables)) + (list (scm->sway-config lines))))) + ;; Default parsing + ((line . lines) + (string-append + (string-join (map ensure-string line)) + "\n" + (scm->sway-config lines))))))) |