scsh-make/make-rule.scm

176 lines
6.1 KiB
Scheme

;;;
;;; 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 (rule-make rule init-state rule-set)
(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))
(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))))
; (send&collect/send client (make-tagged-msg recipient (rule-cmd shutdown)))
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)))
(define (rule-node/make rule listen-ch connect-ch recipients init-state)
(let ((prereqs-results (rule-node/prereqs-results rule connect-ch recipients)))
(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)))))
(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 (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 ()
(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))
(else (error "rule-node: no match")))
(node-loop (collect&reply/receive listen-ch) rcpts)))
'rule-node)))