Commits

Anonymous committed b1a2e73

updated guard-thing to be usable with the test-guard. It notifies via emacs

  • Participants
  • Parent commits 2dd0f25

Comments (0)

Files changed (2)

File guard-like.scm

-;; little guard-like thing 
+;; little guard-like thing
 
+(use posix srfi-69 irregex srfi-1 scsh-process call-with-environment-variables srfi-13)
 
-(use posix srfi-69)
+;; notification framework
 
-(define (monitor-loop directory)
+(define (notify . args)
+  (for-each (lambda (notifier)
+              (apply invoke-notifier notifier args))
+            (notifiers)))
+
+(define (configure-notifier notifier options)
+  (notifier 'configure options))
+
+(define (invoke-notifier notifier . args)
+  (apply notifier 'invoke args))
+
+(define (make-notifier invoker configurator available?)
+  (lambda (msg . args)
+    (case msg
+      ((invoke) (apply invoker args))
+      ((configure) (apply configurator args))
+      ((available) (available?))
+      (else (error "Invalid message " msg)))))
+
+(define notify/emacs
+  (let ((options '((default . "Black")
+                   (failed . "Firebrick")
+                   (success . "ForestGreen")
+                   (font . "White")
+                   (client . "emacsclient"))))
+
+    (define (notify/emacs/configure new-options)
+      (set! options new-options))
+
+    (define (notify/emacs/invoke type title message #!optional image more-options)
+      (let* ((color (alist-ref type options))
+             (font  (alist-ref 'font options))
+             (elisp  (sprintf "(set-face-attribute 'mode-line nil :background \"~A\" :foreground \"~A\")" color font)))
+        (run (emacsclient --eval ,elisp) (> 2 /dev/null))))
+
+    (define (notify/emacs/available)
+      (equal? "no" (read-line (process "emacsclient --eval '1' 2> /dev/null || echo 'no'"))))
+
+    (make-notifier notify/emacs/invoke notify/emacs/configure notify/emacs/available)))
+
+(define notify/tmux (constantly #t))
+
+(define notify/notify-send (constantly #t))
+
+(define notifiers (make-parameter (list notify/tmux notify/notify-send notify/emacs)))
+
+
+;; monitor
+(define (monitor-loop directory #!optional (handler (notifiy-changed-handler debug-events)))
   (let loop ((agenda (make-hash-table string=?)))
     (sleep 1)
-    (loop (run-monitor directory agenda (notify-changed-handler debug-events)))))
+    (loop (run-monitor directory agenda handler))))
 
 (define (run-monitor directory agenda handler)
   (find-files directory seed: agenda action: handler))
   (let ((mtime (modification-time/safe path)))
     (cond
      ((not (in-agenda? path agenda))
-      (event path 'change)
+      (event path 'new)
       (if mtime
 	  (update-agenda agenda path mtime)
 	  agenda))
     agenda)))
 
 ;; on top of this we can actually implement the protocol
+
+(define (guard . plugins)
+  (let ((directory (current-directory)))
+    (monitor-loop directory (notify-changed-handler (run-guards plugins)))))
+
+(define ((run-guards plugins) path event)
+  (for-each (lambda (plugin) (plugin path event)) plugins))
+
+
+
+;; Plugins
+;; little plugin that runs tests and notifies
+
+(define ((test-guard . filters) path event)
+  (when (and
+       (eq? event 'change)
+       (any (lambda (filter) (irregex-match filter path)) filters))
+    (let ((status (run-tests "tests/run.scm")))
+      (notify status "" ""))))
+
+(define (run-tests file)
+  (let ((result
+         (call-with-environment-variables '(("TEST_USE_ANSI" . "1"))
+           (lambda ()
+             (run/string (csi -s ,file))))))
+    (print result)
+    (classify-test-result result)))
+
+(define (classify-test-result result)
+  (let ((fail-pattern "[ \x1b[31mFAIL\x1b[0m]"))
+    (if (string-contains-ci result fail-pattern)
+        'failed
+        'success)))
+
+;; would be invoked like this
+;(guard (test-guard  ".*.scm"))

File system-peep.scm

                   (lambda (key retriever)
                     (cons key (retriever)))))
 
-(define (fact key)
-  (let ((retriever (hash-table-ref *facts* key)))
-    (and retriever (retriever))))
+(define (fact key #!optional (default #f))
+  (let ((retriever (hash-table-ref/default *facts* key #f)))
+    (or (and retriever (retriever)) default)))
 
 )