scsh-make/make.scm

(define (make rules targets . maybe-args)
  (let-optionals maybe-args ((pred string=?)
			     (init-state (list)))
    (let* ((rule-set (rules->rule-set rules))
	   (target-rules (map (lambda (target) 
				(lookup-rule pred target rules)) 
			      targets)))
      (map (lambda (t) 
	     (rule-make t init-state rule-set))
	   target-rules))))

(define (make-rc target prereqs out-of-date?-func thunk)
  (make-rule-cand target 
		  prereqs
		  (lambda args 
		    (let ((init-state (last args)))
		      (cons (out-of-date?-func target prereqs)
			    init-state)))
		  (lambda args 
		    (let ((cooked-state (last args))
			  (results (cdr (reverse (cdr args)))))
		      (cons (bind-all-fluids target prereqs results thunk)
			    cooked-state)))))

(define (file->rc target prereqs thunk)
  (make-rc target prereqs file thunk))

(define (head->rc target prereqs thunk)
  (make-rc target prereqs head thunk))

(define (tail->rc target prereqs thunk)
  (make-rc target prereqs tail thunk))

(define (once->rc target prereqs thunk)
  (make-rc target prereqs once thunk))

(define (all->rc target prereqs thunk)
  (make-rc target prereqs all thunk))

(define (always->rc target prereqs thunk)
  (make-rc target prereqs always thunk))

(define (perms->rc target prereqs thunk)
  (make-rc target prereqs perms thunk))

(define (md5->rc target prereqs thunk)
  (make-rc target prereqs md5 thunk))

(define (md5-perms->rc target prereqs thunk)
  (make-rc target prereqs md5-perms thunk))

(define (paranoid->rc target prereqs thunk)
  (make-rc target prereqs paranoid thunk))

(define (subst-% pattern match)
  (regexp-substitute/global #f (rx (: (submatch (: bos (* any)))
				      (submatch "%") 
				      (submatch (: (* any) eos))))
			    pattern 'pre 1 match 3 'post))

(define (%-pattern->match pattern no)
  (let ((re (rx (: (submatch (: bos (* any)))
		   (submatch "%") 
		   (submatch (: (* any) eos)))))
	(found-%? (regexp-search (rx (: "%")) pattern)))
    (if found-%?
	(match:substring (regexp-search re pattern) no)
	(if (= no 2) pattern ""))))

(define (%-pattern->rx pattern)
  (let* ((left (%-pattern->match pattern 1))
	 (middle (%-pattern->match pattern 2))
	 (right (%-pattern->match pattern 3))
	 (target-rx (if (string=? "%" middle)
			(rx (: (submatch (: bos ,left))
			       (submatch (* any))
			       (submatch (: ,right eos))))
			(rx (: (submatch (: bos ,left))
			       (submatch ,middle)
			       (submatch (: ,right eos)))))))
    target-rx))

(define (file-rx target prereqs thunk)
  (rx->func string=? target prereqs file thunk))

(define (head-rx target prereqs thunk)
  (rx->func string=? target prereqs head thunk))

(define (tail-rx target prereqs thunk)
  (rx->func string=? target prereqs tail thunk))

(define (once-rx target prereqs thunk)
  (rx->func string=? target prereqs once thunk))

(define (all-rx target prereqs thunk)
  (rx->func string=? target prereqs all thunk))

(define (always-rx target prereqs thunk)
  (rx->func string=? target prereqs always thunk))

(define (perms-rx target prereqs thunk)
  (rx->func string=? target prereqs perms thunk))

(define (md5-rx target prereqs thunk)
  (rx->func string=? target prereqs md5 thunk))

(define (md5-perms-rx target prereqs thunk)
  (rx->func string=? target prereqs md5-perms thunk))

(define (paranoid-rx target prereqs thunk)
  (rx->func string=? target prereqs paranoid thunk))

(define (rx->func pred target-rx prereqs out-of-date?-func thunk)
  (lambda (maybe-target)
    (common->func maybe-target target-rx pred
		  out-of-date?-func target-rx prereqs thunk)))

(define (file-% target prereqs thunk)
  (%->func string=? target prereqs file thunk))

(define (head-% target prereqs thunk)
  (%->func string=? target prereqs head thunk))

(define (tail-% target prereqs thunk)
  (%->func string=? target prereqs tail thunk))

(define (once-% target prereqs thunk)
  (%->func string=? target prereqs once thunk))

(define (all-% target prereqs thunk)
  (%->func string=? target prereqs all thunk))

(define (always-% target prereqs thunk)
  (%->func string=? target prereqs always thunk))

(define (perms-% target prereqs thunk)
  (%->func string=? target prereqs perms thunk))

(define (md5-% target prereqs thunk)
  (%->func string=? target prereqs md5 thunk))

(define (md5-perms-% target prereqs thunk)
  (%->func string=? target prereqs md5-perms thunk))

(define (paranoid-% target prereqs thunk)
  (%->func string=? target prereqs paranoid thunk))

(define (%->func pred target-pattern prereqs out-of-date?-func thunk)
  (lambda (maybe-target)
    (let ((target-rx (%-pattern->rx target-pattern)))
      (common->func maybe-target target-rx pred 
		    out-of-date?-func target-pattern prereqs thunk))))

(define (common->func maybe-target target-rx pred 
		      out-of-date?-func target-pattern prereqs thunk)
  (let* ((match-data (regexp-search target-rx maybe-target))
	 (maybe-target-matches (if match-data 
				   (map (lambda (no)
					  (match:substring match-data no))
					(list 1 2 3))
				   #f)))
    (if maybe-target-matches
	(let* ((left (list-ref maybe-target-matches 0))
	       (target-match (list-ref maybe-target-matches 1))
	       (right (list-ref maybe-target-matches 2))
	       (target-name (string-append left target-match right))
	       (cooked-prereqs (map (lambda (prereq) 
				      (if (string? prereq)
					  (subst-% prereq target-match)
					  prereq))
				    prereqs)))
	  (make-rule-cand target-name
			  cooked-prereqs
			  (lambda args 
			    (let ((init-state (last args)))
			      (cons (bind-fluids-common 
				     target-name left target-match right
				     (lambda () 
				       (out-of-date?-func target-name 
							  cooked-prereqs)))
				    init-state)))
			  (lambda args 
			    (let ((cooked-state (last args))
				  (prereqs-results (cdr (reverse (cdr args)))))
			      (cons (bind-fluids-common 
				     target-name left target-match right
				     (lambda () 
				       (bind-all-fluids target-name 
							cooked-prereqs 
							prereqs-results 
							thunk)))
				    cooked-state)))))
	#f)))