summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--catbird/ui.scm54
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
;;;