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 ((maybe-rule (assoc rule (rule-set-rules rule-set))))
    (if (and maybe-rule 
	     (pair? maybe-rule) 
	     (is-collect&reply-channel? (cdr maybe-rule)))
	(cdr maybe-rule)
	(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 (start-threads init-state rule-set)
  (map (lambda (rule) 
	 (let ((listen-ch (rule-set-get-listen-ch rule rule-set)))
	   (rule-node rule listen-ch init-state rule-set)))
       (map car (rule-set-rules rule-set))))

(define (stop-threads init-state rule-set)
  (map (lambda (rule) 
	 (let* ((server (rule-set-get-listen-ch rule rule-set))
		(client (send&collect/make-channel))
		(link (make-link client server))
		(recipient (car link))
		(shutdown (make-tagged-msg recipient (rule-cmd shutdown))))
	   (send&collect/send client shutdown)))
       (map car (rule-set-rules rule-set))))

(define (rule-make rule init-state rule-set)
  (start-threads init-state rule-set)
  (let* ((server (rule-set-get-listen-ch rule rule-set))
	 (client (send&collect/make-channel))
	 (link (make-link client server))
 	 (recipient (car link)))
    (send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
    (let ((res (tagged-msg-stripped (send&collect/receive client))))
      (stop-threads init-state rule-set)
      res)))

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

;;; this only works if there are no duplicates in list
(define (position< maybe-lesser maybe-greater objects)
  (if (null? objects) 
      (error "position< has empty objects-list.")
      (let search-objects ((current (car objects))
			   (todo (cdr objects)))
	(cond
	 ((= (tagged-msg-tag maybe-lesser) current) #t)
	 ((= (tagged-msg-tag maybe-greater) current) #f)
	 ((null? todo) 
	  (error "position<: maybe-lesser or maybe-greater not found."
		 maybe-lesser maybe-greater))
	 (else (search-objects (car todo) (cdr todo)))))))

(define (rule-node/sort-msgs unsorted to-order)
  (map tagged-msg-stripped
       (sort (lambda (maybe-lesser maybe-greater) 
	       (position< maybe-lesser maybe-greater to-order))
	     unsorted (list))))

;;; (define (rule-node/prereqs-results rule connect-ch recipients)
;;;   (let ((unsorted-msgs (map (lambda (recipient) 
;;; 			      (let ((tmsg (make-tagged-msg recipient
;;; 							   (rule-cmd make))))
;;; 				(send&collect/send connect-ch tmsg)
;;; 				(send&collect/receive connect-ch)))
;;; 			    recipients)))
;;;     (rule-node/sort-msgs unsorted-msgs recipients)))

(define (rule-node/prereqs-results rule connect-ch recipients)
  (for-each (lambda (recipient) 
	      (let ((tmsg (make-tagged-msg recipient (rule-cmd make))))
		(send&collect/send connect-ch tmsg)))
	    recipients)
  (let ((unsorted-msgs (map (lambda (ignore) 
			      (send&collect/receive connect-ch))
			    recipients)))
    (rule-node/sort-msgs unsorted-msgs recipients)))

;;; named function for tracing
(define (apply-build-func build-required? rule prereqs prereqs-results cooked-state)
  (let ((build-func (rule-build-func rule)))
    (if (null? prereqs)
	(build-func build-required? cooked-state)
	(apply build-func
	       (append (list build-required?) 
		       prereqs-results (list cooked-state))))))

;;; named function for tracing
(define (apply-wants-build? rule prereqs prereqs-results init-state)
  (let ((wants-build? (rule-wants-build? rule)))
    (if (null? prereqs)
	(wants-build? init-state)
	(apply wants-build? (append prereqs-results (list init-state))))))

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

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

;;; (define (lookup-target rule rule-alist)
;;;   (let ((maybe-targets (filter (lambda (r) (eq? (cdr r) rule)) rule-alist)))
;;;     (if (not (null? maybe-targets))
;;; 	(car (car maybe-targets))
;;; 	(error "lookup-target: rule not found in rule-alist."))))
;;; 
;;; (define target/rule-alist '())
;;; (define (set!-target/rule-alist alist) (set! target/rule-alist alist))

(define (rule-node rule listen-ch init-state rule-set)
  (let* ((connect-ch (send&collect/make-channel))
	 (get-rcpts (lambda ()
		      (map car (rule-node/make-links rule connect-ch rule-set))))
	 (do-answer (lambda (tmsg rcpts)
		      (let* ((sender (tagged-msg-tag tmsg))
			     (cmd (tagged-msg-stripped tmsg))
			     (result (rule-node/make rule listen-ch connect-ch 
						     rcpts init-state))
			     (reply (make-tagged-msg sender result)))
			(collect&reply/send listen-ch reply)))))
    (spawn
      (lambda () 
;;;	(display (lookup-target rule target/rule-alist)) (newline)
	(let node-loop ((tmsg (collect&reply/receive listen-ch))
			(rcpts (get-rcpts)))
	  (cond
	   ((eq? (rule-cmd-name (tagged-msg-stripped tmsg)) 'make)
	    (do-answer tmsg rcpts))
	   ((eq? (rule-cmd-name (tagged-msg-stripped tmsg)) 'shutdown)
	    (terminate-current-thread))
	   (else (error "rule-node: no match")))
	  (node-loop (collect&reply/receive listen-ch) rcpts)))
      'rule-node)))