diff options
| -rw-r--r-- | catbird/ui.scm | 54 |
1 files changed, 54 insertions, 0 deletions
diff --git a/catbird/ui.scm b/catbird/ui.scm index c6470b6..7809226 100644 --- a/catbird/ui.scm +++ b/catbird/ui.scm @@ -32,6 +32,7 @@ #:use-module (ice-9 match) #:use-module (oop goops) #:use-module (srfi srfi-1) + #:use-module (web uri) #:export (accepts-cursor-focus? on-cursor-enter on-cursor-exit @@ -55,6 +56,9 @@ <vertical-container> + <link> + uri + <button> background-up background-down @@ -252,6 +256,56 @@ ;;; +;;; Links +;;; + +(define-class <link> (<label>) + (uri #:accessor uri #:init-keyword #:uri #:init-value #f)) + +(define-method (initialize (link <link>) initargs) + (next-method) + ;; Automatically convert strings to URI objects. + (when (string? (uri link)) + (set! (uri link) (string->uri (uri link)))) + ;; If no link text was given, default to the URI string. + (when (string-null? (text link)) + (set! (text link) (uri->string (uri link)))) + (set! (color link) tango-aluminium-1)) + +(define-method (accepts-cursor-focus? (link <link>)) + #t) + +;; TODO: Make this customizable. Even better, tap into the desktop +;; environment to open with preferred programs. +(define-method (visit-uri (link <link>)) + (let ((uri (uri link))) + (case (uri-scheme uri) + ((file) + (let ((args (match (string-split (uri-path uri) #\:) + ((file) + (list file)) + ((file line) + (list (string-append "+" line) file)) + ((file line column) + (list (string-append "+" line ":" column) file))))) + (apply system* "emacsclient" "-n" args)))))) + +(define-method (on-cursor-enter (link <link>)) + (set! (color link) blue) + (next-method)) + +(define-method (on-cursor-exit (link <link>)) + (set! (color link) tango-aluminium-1) + (next-method)) + +(define-method (on-primary-click (link <link>)) + (pk 'link link) + (when (uri link) + (visit-uri link)) + (next-method)) + + +;;; ;;; Buttons ;;; |