syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Avoid accidental n^2 in filesystem driver; make.rkt example

This commit is contained in:
Tony Garnock-Jones 2017-09-28 19:27:21 +01:00
parent 7a4d528dc0
commit fa257a1d16
2 changed files with 59 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
racket/syndicate/drivers/filesystem.rkt
View File

@ -20,29 +20,24 @@
(spawn #:name 'filesystem-driver
(during/spawn (observe (file-content $name $reader-proc _))
#:name (list 'file-content name reader-proc)
(track-file name reader-proc))))
(track-file name reader-proc))
(during (observe (inbound (file-changed $name)))
(monitor-thread name))))
(define (read-file name reader-proc)
(and (or (file-exists? name) (directory-exists? name))
(reader-proc name)))
(define (path->parent-path name)
(let-values (((parent-path _leaf _syntactically-dir?)
(split-path (path->complete-path name))))
parent-path))
(define (track-file name reader-proc)
(define control-ch (make-channel))
(define parent-path
(let-values (((parent-path _leaf _syntactically-dir?)
(split-path (path->complete-path name))))
parent-path))
(thread (lambda () (track-file-changes name parent-path control-ch)))
(field [content (read-file name reader-proc)])
(assert (file-content name reader-proc (content)))
(on (message (inbound (file-changed name)))
(content (read-file name reader-proc)))
;; This horrible hack is required to work around limitations in the
;; OS's file-change reporting. It seems (?) as if, monitoring both
;; "a/b" and "a/", that only the event for "a/" will be fired when
@ -56,30 +51,32 @@
;; file-container-changed events for ALL recursive parents of the
;; path of interest up to the root.
;;
(on (message (inbound (file-container-changed parent-path)))
(content (read-file name reader-proc)))
(on (message (inbound (file-container-changed (path->parent-path name))))
(content (read-file name reader-proc))))
(define (monitor-thread name)
(define control-ch (make-channel))
(thread (lambda ()
(define parent-path (path->parent-path name))
(let loop ()
(sync (handle-evt control-ch
(lambda (msg)
;; (log-info "track-file-changes ~v: ~v" name msg)
(match msg
['quit (void)])))
(if (or (file-exists? name) (directory-exists? name)) ;; TODO: TOCTTOU :-(
(handle-evt (filesystem-change-evt name)
(lambda (_dummy)
;; (log-info "track-file-changes ~v: changed" name)
(send-ground-message (file-changed name))
(loop)))
(handle-evt (filesystem-change-evt parent-path)
(lambda (_dummy)
;; (log-info "track-file-changes ~v: directory changed" name)
(send-ground-message (file-container-changed parent-path))
(loop))))))))
(on-stop (channel-put control-ch 'quit)))
(define (track-file-changes name parent-path control-ch)
(let loop ()
(sync (handle-evt control-ch
(lambda (msg)
;; (log-info "track-file-changes ~v: ~v" name msg)
(match msg
['quit (void)])))
(if (or (file-exists? name) (directory-exists? name)) ;; TODO: TOCTTOU :-(
(handle-evt (filesystem-change-evt name)
(lambda (_dummy)
;; (log-info "track-file-changes ~v: changed" name)
(send-ground-message (file-changed name))
(loop)))
(handle-evt (filesystem-change-evt parent-path)
(lambda (_dummy)
;; (log-info "track-file-changes ~v: directory changed" name)
(send-ground-message (file-container-changed parent-path))
(loop)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn-filesystem-driver)

28
racket/syndicate/examples/actor/make.rkt Normal file
View File

@ -0,0 +1,28 @@
#lang syndicate
;; Automagic "make"-like utility.
(require/activate syndicate/drivers/filesystem)
(require racket/string)
(require racket/system)
(require file/sha1)
(define (file->sha1 p)
(call-with-input-file p sha1))
(spawn (during (observe (file-content $name _ _))
(when (not (string-suffix? name ".c"))
(define name.c (string-append name ".c"))
(on-start (printf "Tracking ~a, to see if we can use it to build ~a\n" name.c name))
(during (file-content name.c file->sha1 $hash) ;; nb. $hash, not _
(on-start
(if hash
(begin (printf "~a has changed hash to ~a, recompiling\n" name.c hash)
(system* (find-executable-path "cc") "-o" name name.c))
(printf "~a doesn't exist.\n" name.c)))))))
(spawn (on (asserted (file-content "." directory-list $files))
(for [(name-path (in-list files))]
(match (path->string name-path)
[(pregexp #px"(.*)\\.c" (list _ name))
(assert! (observe (file-content name file-exists? #t)))]
[_ (void)]))))