scsh-make/common-rules.scm

(define-record-type :common-rule
  (really-make-common-rule target prereqs wants-build? build-func)
  is-common-rule?
  (target common-rule-target)
  (prereqs common-rule-prereqs)
  (wants-build? common-rule-wants-build?)
  (build-func common-rule-build-func))

(define (make-empty-common-rules) 
  (let* ((target-pattern "%")
	 (make-does-file-exist? (lambda (target-name . cooked-prereqs)
			      (lambda args 
				(cons (file-not-exists? target-name) 
				      (last args)))))
	 (make-error-if-not-exists (lambda (target-name . cooked-prereqs)
		       (lambda args
			 (error "file (assumed leaf) does not exist:" 
				target-name))))
	 (common-rule (really-make-common-rule target-pattern
					       (list) 
					       make-does-file-exist?
					       make-error-if-not-exists)))
    (list common-rule)))

(define (common-rules-add common-rules descr)
  (let ((target (list-ref descr 0))
	(prereqs (list-ref descr 1))
	(wants-build? (list-ref descr 2))
	(build-func (list-ref descr 3)))
    (cons (really-make-common-rule target prereqs wants-build? build-func)
	  common-rules)))

(define (search-match-in-common-rules common-rules target)
  (if (null? common-rules)
      #f
      (let next-common-rule ((current (car common-rules))
			     (todo (cdr common-rules)))
	(let ((maybe-target (is-matched-by? (common-rule-target current) target)))
	  (if maybe-target
	      (let* ((prefix (list-ref maybe-target 0))
		     (match (list-ref maybe-target 1))
		     (suffix (list-ref maybe-target 2))
		     (target-name (string-append prefix match suffix))
		     (cooked-prereqs (map (lambda (prereq)
					    (if (string? prereq) 
						(replace-by-match prereq match)
						prereq))
					  (common-rule-prereqs current)))
		     (make-wants-build? (common-rule-wants-build? current))
 		     (wants-build? 
		      (lambda args 
			(bind-fluids-common target-name prefix match suffix
					    (lambda () 
					      (apply
					       (apply make-wants-build? 
						      (append (list target-name) 
							      cooked-prereqs))
					       args)))))
		     (make-build-func (common-rule-build-func current))
		     (build-func 
		      (lambda args
			(bind-fluids-common target-name prefix match suffix 
					    (lambda () 
					      (apply 
					       (make-build-func target-name 
								cooked-prereqs)
					       args))))))
		(list target-name cooked-prereqs wants-build? build-func))
	      (if (null? todo)
		  #f
		  (next-common-rule (car todo) (cdr todo))))))))

(define (common-rcs->common-rules common-rules)
  (let ((empty-rules (make-empty-common-rules))
	(common-rcs common-rules)) ; maybe reverse list
    (if (null? common-rcs)
	empty-rules
	(let each-rc ((rc (car common-rcs))
		      (todo (cdr common-rcs))
		      (done empty-rules))
	  (if (null? todo)
	      (common-rules-add done rc)
	      (each-rc (car todo) (cdr todo) (common-rules-add done rc)))))))

;;; 
;;; returns a list containing three elements or false
;;; the first element is the left part of the match
;;; the second element is the middle part of the match
;;; the third element is the right part of the match
;;;
;;; (is-matched-by? "%.o" "bar.o") ---> '("" "bar" ".o")
;;; (is-matched-by? "%.tex" "bar.o") ---> #f
;;; 
(define (is-matched-by? target-descr target-name)
  (let ((submatches (if (string? target-descr)
			(get-submatches-percent target-descr)
			#f)))
    (if submatches 
	(let* ((left (list-ref submatches 0))
	       (middle (list-ref submatches 1))
	       (right (list-ref submatches 2))
	       (constructed-rx (if (and (string? middle) (string=? "%" middle))
				   (rx (: (submatch ,left) 
					  (submatch (* any))
					  (submatch ,right)))
				   (rx (: (submatch ,left)
					  (submatch ,middle)
					  (submatch ,right)))))
	       (maybe-match (regexp-search constructed-rx target-name)))
	  (if maybe-match
	      (map (lambda (match-no)
		     (match:substring maybe-match match-no))
		   (list 1 2 3))
	      #f))
	(let ((maybe-match (regexp-search target-descr target-name)))
	  (if maybe-match
	      (map (lambda (match-no) (match:substring maybe-match match-no))
		   (list 1 2 3))
	      #f)))))

(define (get-submatches-percent target-descr)
  (map (lambda (match-no)
	 (match:substring (regexp-search (rx (: (submatch (* any))
						(submatch "%") 
						(submatch (* any)))) 
					 target-descr)
			  match-no))
       (list 1 2 3)))

;;; 
;;; returns the string where the match is replaced with replacement
;;; or the identity of maybe-match
;;; 
;;; (replace-by-match "no-percents.c" "foo") ---> "no-percents.c"
;;; (replace-by-match "%.c" "foo") ---> "foo.c"
;;; 
(define (replace-by-match maybe-match replacement)
  (regexp-substitute/global 
   #f 
   (rx (: (submatch (* any)) (submatch "%") (submatch (* any))))
   maybe-match
   'pre 1 replacement 3 'post))

(define (common-rules-show common-rules)
  (display "\n=== \n=== COMMON RULES") (newline)
  (for-each (lambda (common-rule)
	      (display "=== ") (newline)
	      (let* ((target (common-rule-target common-rule))
		     (prereqs (common-rule-prereqs common-rule))
		     (wants-build? (common-rule-wants-build? common-rule))
		     (build-func (common-rule-build-func common-rule)))
		(display "=== target       : ") (display target) (newline)
		(display "=== prereqs      : ") (display prereqs) (newline)
		(display "=== wants-build? : ") (display wants-build?) (newline)
		(display "=== build-func   : ") (display build-func) (newline)))
	    common-rules)
  (newline))