Commits

certainty  committed a57f1c3

made it compile

  • Participants
  • Parent commits d2bd742

Comments (0)

Files changed (3)

  (author "David Krentzlin")
  (category tools)
  (license "GPL")
- (depends)
- (test-depends)
+ (depends (mailbox-threads scsh-process call-with-environment-variables))
+ (test-depends test)
  (foreign-depends))
 (module sentry
 
-()
+  (sentry notify configure-notifier invoke-notifier make-notifier notifiers register-notifier)
 
-(import chicken scheme)
+  (import chicken scheme posix srfi-69 data-structures mailbox-threads)
+
+;; Notification framework
+(define notifiers (make-parameter (list)))
+
+(define ( register-notifier notifier)
+  (notifiers (cons notifier (notifiers))))
+
+(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)))))
+
+;; monitor
+(define (monitor-directory directory monitor #!key (options '()) (event-handler (notify-changed-handler (constantly #t))) (foreground #f))
+  (let ((body (lambda ()
+                (monitor directory event-handler options: options))))
+    (if foreground
+        (body)
+        (make-thread body))))
+
+
+(define (polling-monitor directory handler #!key (options '()))
+  (let ((sleeptime (or (alist-ref 'sleep options) 1)))
+    (let loop ((agenda (make-agenda)))
+      (sleep sleeptime)
+      (loop (one-polling-round directory agenda handler)))))
+
+(define (one-polling-round directory agenda handler)
+  (let ((action (lambda (path event)
+                  (handler path agenda))))
+    (find-files directory seed: agenda action: action)))
+
+
+(define (monitor-loop directory #!optional (handler (notify-changed-handler (constantly #t))))
+  (let loop ((agenda (make-hash-table string=?)))
+    (sleep 1)
+    (loop (run-monitor directory agenda handler))))
+
+(define (run-monitor directory agenda handler)
+  (find-files directory seed: agenda action: handler))
+
+(define (make-agenda)
+  (make-hash-table string=?))
+
+(define (in-agenda? path agenda)
+  (hash-table-exists? agenda path))
+
+(define (update-agenda agenda path mtime)
+  (hash-table-set! agenda path mtime)
+  agenda)
+
+(define (last-modified path agenda)
+  (hash-table-ref/default agenda path #f))
+
+(define (file-modified? path last-modified)
+  (and last-modified (> (file-modification-time path) last-modified)))
+
+(define (modification-time/safe path)
+  (handle-exceptions exn #f (file-modification-time path)))
+
+(define ((notify-changed-handler event) path agenda)
+  (let ((mtime (modification-time/safe path)))
+    (cond
+     ((not (in-agenda? path agenda))
+      (event path 'new)
+      (if mtime
+	  (update-agenda agenda path mtime)
+	  agenda))
+   ((file-modified? path (last-modified path agenda))
+    (event path 'change)
+    (if mtime
+	(update-agenda agenda path mtime)
+	agenda))
+   (else agenda))))
+
+(define ((notify-all-handler event) path agenda)
+  (cond
+   ((not (in-agenda? path agenda))
+    (event path 'change)
+    (update-agenda agenda path (file-modification-time path)))
+   (else
+    (event path 'change)
+    agenda)))
+
+;; on top of this we can actually implement the protocol
+(define (sentry . plugins)
+  (let ((directory (current-directory)))
+    (monitor-loop directory (notify-changed-handler (run-sentries plugins)))))
+
+(define ((run-sentries plugins) path event)
+  (for-each (lambda (plugin) (plugin path event)) plugins))
+
+;; would be invoked like this
+;; (sentry
+;;   (test-guard  ".*.scm"))
 
 )

File sentry.setup

  'sentry
  '("sentry.so" "sentry.import.so")
  '((version "0.0.1")))
+
+
+(compile -d0 -O2 -J -s sentry-notify-emacs.scm)
+(compile -d0 -O2 -s sentry-notify-emacs.import.scm)
+
+(install-extension
+ 'sentry-notify-emacs
+ '("sentry-notify-emacs.so" "sentry-notify-emacs.import.scm")
+ '((version "0.0.1")))
+
+(compile -d0 -O2 -J -s sentry-plugin-test.scm)
+(compile -d0 -O2 -s sentry-plugin-test.import.scm)
+
+(install-extension
+ 'sentry-plugin-test
+ '("sentry-plugin-test.so" "sentry-plugin-test.import.scm")
+ '((version "0.0.1")))