;;; TODO:
;;; 
;;; (update-md-sum ...) is (due to history) not very lucky 
;;; 
(define digest-files (list "checksums.md5"
			   "fingerprints.md5"
			   "digests.md5"))

(define digest-extensions (list ".md5" ".fp" ".digest"))

(define (make-rule-build-func target prereqs thunk)
  (lambda args 
    (cons (begin 
	    (display ";;; rule      : ")
	    (display target)
	    (newline)
	    (thunk)) 
	  (last args))))

(define (make-md5-build-func target prereqs thunk)
  (lambda args 
    (cons (begin 
	    (display ";;; md5       : ")
	    (display target)
	    (newline)
	    (thunk))
	  (last args))))

(define (make-always-build-func target prereqs thunk)
  (lambda args 
    (cons (begin 
	    (display ";;; always    : ")
	    (display target)
	    (newline)
	    (thunk))
	  (last args))))

(define (make-once-build-func target prereqs thunk)
  (lambda args 
    (cons (begin 
	    (display ";;; once      : ")
	    (display target)
	    (newline)
	    (thunk)) 
	  (last args))))

(define (make-is-out-of-date! target . prereqs)
  ;; init-state is the last arg
  ;; pass it untouched to the result
  (lambda args (cons #t (last args))))

(define (make-once target . prereqs)
  ;; init-state is the last arg
  ;; pass it untouched to the result
  (lambda args (cons (file-not-exists? target) (last args))))

(define (make-is-out-of-date? target . prereqs)
  (lambda args 
    (let ((init-state (last args)))
      (cons (or (file-not-exists? target)
		(and (not (null? prereqs))
		     (let for-each-prereq ((prereq (car prereqs))
					   (todo (cdr prereqs)))
		       (and (file-exists? prereq)
			    (> (file-last-mod prereq)
			       (file-last-mod target))
			    (or (null? todo)
				(for-each-prereq (car todo) (cdr todo)))))))
	    init-state))))

(define (make-md5-sum-changed? target . prereqs)
  (lambda args 
    (let ((init-state (last args))
	  (tfname (expand-file-name target (cwd))))
      (cons (or (file-not-exists? tfname)
		(or (null? prereqs)
		    (let for-each-prereq ((prereq (car prereqs))
					  (todo (cdr prereqs)))
		      (let ((pname (expand-file-name prereq (cwd))))
			(or (and (file-exists? pname)
				 (> (file-last-mod pname)
				    (file-last-mod tfname))
				 (checksum-changed? pname)
				 (or (md5-sum-update pname) #t))
			    (and (not (null? todo))
				 (for-each-prereq (car todo) (cdr todo))))))))
	    init-state))))

(define (check-files-target+extensions target checksum)
  (map (lambda (digest-file)
	 (lambda ()
	   (let ((dfile (expand-file-name digest-file (cwd))))
	     (or (file-not-exists? dfile)
		 (let ((strls (port->string-list (open-input-file dfile))))
		   (= checksum 
		      (string->number (if (null? strls) "" (car strls)))))))))
       (map  (lambda (ext) 
	       (string-append target ext))
	     digest-extensions)))

(define (update-files-target+extensions target checksum)
  (map (lambda (digest-file)
	 (lambda ()
	   (let ((dfile (expand-file-name digest-file (cwd))))
	     (and (file-exists? dfile)
		  (let ((outport (open-output-file dfile)))
		    (display ";;; update    : ") (display target) (newline)
		    (with-current-output-port 
		     outport
		     (lambda ()
		       (display (number->string checksum)) (newline)))
		    (close outport)
		    #t)))))
       (map  (lambda (ext) 
	       (string-append target ext))
	     digest-extensions)))

(define (digest-file->string-list digest-fname)
  (let* ((inport (open-input-file (expand-file-name digest-fname (cwd))))
	 (strls (map (lambda (str) 
		       (let ((ls (string-tokenize str)))
			 (if (not (null? ls))
			     (let ((fp (car ls))
				   (name (cadr ls)))
			       (cons name fp))
			     '())))
		     (port->string-list inport))))
    (close inport)
    strls))

(define (check-digest-files target checksum)
  (map (lambda (digest-file)
	 (lambda ()
	   (let ((dfile (expand-file-name digest-file (cwd)))
		 (tname (file-name-nondirectory target)))
	     (or (file-not-exists? dfile)
		 (let* ((*fname-md5* (digest-file->string-list dfile))
			(maybe-md5 (if (or (null? *fname-md5*) 
					   (null? (car *fname-md5*)))
				       #f
				       (assoc tname *fname-md5*))))
		   (or (not maybe-md5)
		       (= checksum
			  (string->number (cdr maybe-md5)))))))))
       digest-files))

(define (string-list->digest-file dfname strls)
  (let ((outport (open-output-file (expand-file-name dfname (cwd))))
	(names (if (or (null? strls) (null? (car strls))) '() (map car strls)))
	(sums (if (or (null? strls) (null? (car strls))) '() (map cdr strls))))
    (display ";;; update    : ") (display dfname) (newline)
    (for-each (lambda (name fp)
		(with-current-output-port outport
					  (for-each display (list fp " " name))
					  (newline)))
	      names sums)
    (close outport)
    #t))

(define (update-digest-files target checksum)
  (map (lambda (digest-file)
	 (lambda ()
	   (let ((dfile (expand-file-name digest-file (cwd)))
		 (tname (file-name-nondirectory target)))
	     (and (file-exists? dfile)
		  (let* ((*fname-md5* (digest-file->string-list dfile))
			 (cleaned-table (if (or (null? *fname-md5*)
						(null? (car *fname-md5*)))
					    (list)
					    (alist-delete tname *fname-md5*))))
		    (string-list->digest-file 
		     dfile
		     (alist-cons tname checksum cleaned-table)))))))
       digest-files))

(define (checksum-changed? target)
  (let* ((inport (open-input-file target))
	 (checksum (md5-digest->number (md5-digest-for-port inport)))
	 (result-funcs (append (check-files-target+extensions target checksum)
			       (check-digest-files target checksum))))
    (close inport)
    (not (let each-result-and ((current (car result-funcs))
			       (todo (cdr result-funcs)))
	   (let ((res (current)))
	     (and res
		  (or (null? todo)
		      (each-result-and (car todo) (cdr todo)))))))))

(define (md5-sum-update target)
  (let* ((tname (expand-file-name target (cwd)))
	 (inport (open-input-file tname))
         (checksum (md5-digest->number (md5-digest-for-port inport)))
	 (update-funcs (append (update-files-target+extensions target checksum)
			       (update-digest-files target checksum))))
    (close inport)
    (let ((update-ok? (lambda ()
			(let each-update-and ((current (car update-funcs))
					      (todo (cdr update-funcs)))
			  (or (current)
			      (and (not (null? todo))
				   (each-update-and (car todo) (cdr todo))))))))
      ;; the default is to use the filename with .md5 extension
      (if (not (update-ok?))
	  (let ((outport (open-output-file (string-append tname ".md5"))))
	    (with-current-output-port outport
				      (begin
					(display checksum)
					(newline)))
	    (close outport))))))