Avoid accidental n^2 in filesystem driver; make.rkt example
This commit is contained in:
parent
7a4d528dc0
commit
fa257a1d16
|
@ -20,29 +20,24 @@
|
||||||
(spawn #:name 'filesystem-driver
|
(spawn #:name 'filesystem-driver
|
||||||
(during/spawn (observe (file-content $name $reader-proc _))
|
(during/spawn (observe (file-content $name $reader-proc _))
|
||||||
#:name (list '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)
|
(define (read-file name reader-proc)
|
||||||
(and (or (file-exists? name) (directory-exists? name))
|
(and (or (file-exists? name) (directory-exists? name))
|
||||||
(reader-proc 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 (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)])
|
(field [content (read-file name reader-proc)])
|
||||||
|
|
||||||
(assert (file-content name reader-proc (content)))
|
(assert (file-content name reader-proc (content)))
|
||||||
|
|
||||||
(on (message (inbound (file-changed name)))
|
(on (message (inbound (file-changed name)))
|
||||||
(content (read-file name reader-proc)))
|
(content (read-file name reader-proc)))
|
||||||
|
|
||||||
;; This horrible hack is required to work around limitations in the
|
;; This horrible hack is required to work around limitations in the
|
||||||
;; OS's file-change reporting. It seems (?) as if, monitoring both
|
;; 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
|
;; "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
|
;; file-container-changed events for ALL recursive parents of the
|
||||||
;; path of interest up to the root.
|
;; path of interest up to the root.
|
||||||
;;
|
;;
|
||||||
(on (message (inbound (file-container-changed parent-path)))
|
(on (message (inbound (file-container-changed (path->parent-path name))))
|
||||||
(content (read-file name reader-proc)))
|
(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)))
|
(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)
|
(spawn-filesystem-driver)
|
||||||
|
|
|
@ -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)]))))
|
Loading…
Reference in New Issue