Add really hacky <link> node class.

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