scsh-make/make-rule.scm

;;;
;;; RULE
;;;
;;; (make-rule prereqs wants-build? build-func) ---> rule
;;;
;;; prereqs: '(#{:rule} ...)
;;; wants-build?: (lambda (res-p0 res-p1 ... res-pN init-state) body ...)
;;;               res-pX: result of prerequisite-rule no. X
;;;   (wants-build? res-p0 ... res-pN init-state) 
;;;      ---> (res-wants-build? . cooked-state)
;;; build-func: 
;;;   (lambda (res-wants-build? res-p0 ... res-pN cooked-state) 
;;;      ---> (res-build-func . end-state)
;;;
(define-record-type :rule
  (make-rule prereqs wants-build? build-func)
  is-rule?
  (prereqs rule-prereqs)
  (wants-build? rule-wants-build?)
  (build-func rule-build-func))

;;;
;;; RULE-SET
;;;
;;; (make-empty-rule-set) ---> rule-set
;;; (rule-set-add! rule rule-set) ---> rule-set
;;;
(define-record-type :rule-set
  (make-rule-set rules)
  is-rule-set?
 (rules rule-set-rules))

(define (make-empty-rule-set) 
  (make-rule-set '()))

(define (rule-set-add rule rule-set)
  (let ((listen-ch (collect&reply/make-channel)))
    (if (not (assq rule (rule-set-rules rule-set)))
	(make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set)))
	(error "make-rule: rule already exists."))))

(define (rule-set-get-listen-ch rule rule-set)
  (let ((?thing (assq rule (rule-set-rules rule-set))))
    (if (and ?thing (pair? ?thing) (is-collect&reply-channel? (cdr ?thing)))
	(cdr ?thing)
	(error "Rule not found in rule-set."))))

;;;
;;; RULE-RESULT
;;; 
;;; (rule-result-wants-build? rule-result) --->  
;;;    (wants-build?-result . cooked-state) oder (#f . cooked-state) 
;;; 
;;; (rule-result-build-func rule-result) --->  
;;;    (build-func-result . end-state) oder #f 
;;; 
;;; (rule-make rule init-state rule-set) ---> rule-result
;;; 
(define-record-type :rule-result
  (make-rule-result wants-build?-result build-func-result)
  is-rule-result?
  (wants-build?-result rule-result-wants-build?)
  (build-func-result rule-result-build-func))

(define (rule-make rule init-state rule-set)
  ;;
  ;; this could be rewritten in future
  ;; 
  ;; check for unused threads -> dont start them
  ;;
  (map (lambda (r) 
	 (rule-node r (rule-set-get-listen-ch r rule-set) init-state rule-set))
       (map car (rule-set-rules rule-set)))
  (let* ((server (rule-set-get-listen-ch rule rule-set))
	 (client (send&collect/make-channel))
	 (recipient (make-link client server)))
    (send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
    (tagged-msg-stripped (send&collect/receive client))))

(define-enumerated-type rule-cmd :rule-cmd
  is-rule-cmd?
  the-rule-cmds
  rule-cmd-name
  rule-cmd-index
  (make link shutdown))

(define (rule-node/sort-msgs unsorted to-order)
  (map (lambda (pos)
	 (map (lambda (tmsg)
		(let ((msg (tagged-msg-stripped tmsg))
		      (sender (tagged-msg-tag tmsg)))
		  (if (eq? sender pos)
		      msg)))
	      unsorted))
       to-order))

;;; send each prereq-thread a make command and the init-state
;;; then wait for the results to return 
;;; sort to the order they were sent and ciao
(define (rule-node/get-prereqs-results rule connect-ch recipients init-state)
  (rule-node/sort-msgs (map 
			(lambda (recipient)
			  (send&collect/send connect-ch 
					     (make-tagged-msg recipient 
							      (rule-cmd make)))
			  (send&collect/receive connect-ch))
			recipients)
		       recipients))

(define (rule-node/make rule listen-ch connect-ch recipients init-state)
  (let* ((prereqs-results (rule-node/get-prereqs-results rule connect-ch
							 recipients init-state))
	 (wants-build?-result (call-with-values
				  (lambda ()
				    (apply values (append prereqs-results
							  (list init-state))))
				(rule-wants-build? rule)))
	 (build-required? (car wants-build?-result))
	 (cooked-state (cdr wants-build?-result)))
    (if build-required? 
	(make-rule-result wants-build?-result
			  (call-with-values 
			      (lambda () 
				(apply values (append (list build-required?)
						      prereqs-results 
						      (list cooked-state))))
			    (rule-build-func rule)))
	(make-rule-result wants-build?-result #f))))

(define (rule-node/make-links rule connect-ch rule-set)
  (let ((listen-chs (map (lambda (r) 
			   (cdr (assq r (rule-set-rules rule-set))))
			 (rule-prereqs rule))))
    (map (lambda (listen-ch)
	   (make-link connect-ch listen-ch))
	 listen-chs)))

(define (rule-node rule listen-ch init-state rule-set)
  (let ((connect-ch (send&collect/make-channel)))
    (spawn
      (lambda () 
	;; 
	;; wait for anything on the listen-ch
	;; check if it is a known command
	;; if so: process this command
	;; otherwise it was noise
	;; 
	;; if its the first time the make command drops in
	;; initially make the connections to every prereq-listen-ch
	;; 
	(let node-loop ((tmsg (collect&reply/receive listen-ch))
			(?recipients #f))
	  (let ((sender (tagged-msg-tag tmsg))
		(cmd (tagged-msg-stripped tmsg)))
	    (cond
	     ((eq? (rule-cmd-name cmd) 'make)
	      (if (not ?recipients) 
		  (set! ?recipients 
			(rule-node/make-links rule connect-ch rule-set)))
	      (let ((res (rule-node/make rule listen-ch connect-ch 
					 ?recipients init-state)))
		(collect&reply/send listen-ch (make-tagged-msg sender res))))
	     ((eq? (rule-cmd-name cmd) 'shutdown) (terminate-current-thread))))
	  (node-loop (collect&reply/receive listen-ch) ?recipients)))
      'rule-node)))