racket-makefile/private/engine.rkt

#lang racket/base

(require racket/list)

(provide makefile-targets
         current-makefile-prefix
         begin-makefile!
         register-target!
         mark-phony!
         set-default-target!
         reset-makefiles!
         call-target-procedure
         make-targets!
         current-target
         current-dependencies
         current-first-dependency)

;; Target procedures are registered globally per makefile prefix.  The value is
;; deliberately the real target procedure; `make` ultimately resolves a target
;; in this hash and calls that procedure.
(define makefile-targets (make-hash))
(define target-dependencies (make-hash))
(define phony-targets (make-hash))
(define target-order (make-hash))
(define default-targets (make-hash))

;; The most recently evaluated makefile becomes the active makefile.  Setting a
;; parameter without parameterize is persistent for the current thread, which
;; is exactly what the interactive DrRacket/Rash use needs.
(define current-makefile-prefix (make-parameter #f))

(define current-target (make-parameter #f))
(define current-dependencies (make-parameter #f))
(define current-first-dependency (make-parameter #f))

(define (prefix-key value)
  (cond
    [(symbol? value) (symbol->string value)]
    [(path? value) (path->string value)]
    [(string? value) value]
    [else (raise-argument-error 'makefile-prefix "(or/c symbol? path-string?)" value)]))

(define (target-key value)
  (cond
    [(symbol? value) (symbol->string value)]
    [(path? value) (path->string value)]
    [(string? value) value]
    [else (raise-argument-error 'target "(or/c symbol? path-string?)" value)]))

(define (registry-key prefix target)
  (cons (prefix-key prefix) (target-key target)))

(define (target-keys value)
  (if (list? value)
      (append-map target-keys value)
      (list (target-key value))))

(define (clear-prefix! prefix)
  (define pkey (prefix-key prefix))
  (for ([key (in-list (hash-keys makefile-targets))])
    (when (equal? (car key) pkey)
      (hash-remove! makefile-targets key)
      (hash-remove! target-dependencies key)
      (hash-remove! phony-targets key)))
  (hash-remove! target-order pkey)
  (hash-remove! default-targets pkey)
  (void))

(define (begin-makefile! prefix)
  (clear-prefix! prefix)
  (void))

(define (reset-makefiles!)
  (hash-clear! makefile-targets)
  (hash-clear! target-dependencies)
  (hash-clear! phony-targets)
  (hash-clear! target-order)
  (hash-clear! default-targets)
  (current-makefile-prefix #f)
  (void))

(define (register-target! prefix name dependencies procedure)
  (define pkey (prefix-key prefix))
  (define tkey (target-key name))
  (define key (cons pkey tkey))

  (unless (hash-has-key? makefile-targets key)
    (hash-set! target-order
               pkey
               (append (hash-ref target-order pkey '()) (list tkey))))

  (hash-set! makefile-targets key procedure)
  (hash-set! target-dependencies key (append-map target-keys dependencies))
  (void))

(define (mark-phony! prefix . names)
  (for* ([name (in-list names)]
         [tkey (in-list (target-keys name))])
    (hash-set! phony-targets (cons (prefix-key prefix) tkey) #t))
  (void))

(define (set-default-target! prefix name)
  (hash-set! default-targets (prefix-key prefix) (target-key name))
  (void))

(define (target-procedure prefix name)
  (hash-ref makefile-targets
            (registry-key prefix name)
            (λ ()
              (error 'racket-makefile
                     "unknown target ~a for makefile ~a"
                     name
                     prefix))))

(define (dependencies-for prefix name)
  (hash-ref target-dependencies (registry-key prefix name) '()))

(define (call-target-procedure prefix name body)
  (define dependencies (dependencies-for prefix name))
  (parameterize ([current-target (target-key name)]
                 [current-dependencies dependencies]
                 [current-first-dependency
                  (if (null? dependencies) #f (car dependencies))])
    (body))
  (void))

(define (phony? prefix name)
  (hash-ref phony-targets (registry-key prefix name) #f))

(define (path-modify-seconds path)
  (file-or-directory-modify-seconds path #f (λ () #f)))

(define (registered-target? prefix name)
  (hash-has-key? makefile-targets (registry-key prefix name)))

(define (dependency-time prefix name built-results)
  (cond
    [(phony? prefix name) +inf.0]
    [(registered-target? prefix name)
     (define result (hash-ref built-results (target-key name) #f))
     (or (path-modify-seconds name)
         (if result +inf.0 #f))]
    [else
     (or (path-modify-seconds name)
         (error 'racket-makefile
                "dependency does not exist and has no target: ~a"
                name))]))

(define (needs-build? prefix name dependencies built-results)
  (cond
    [(phony? prefix name) #t]
    [else
     (define target-time (path-modify-seconds name))
     (cond
       [(not target-time) #t]
       [else
        (for/or ([dependency (in-list dependencies)])
          (define dep-time (dependency-time prefix dependency built-results))
          (and dep-time (> dep-time target-time)))])]))

(define (execute-target! prefix name)
  (printf "racket-makefile[~a]: ~a\n" prefix (target-key name))
  ((target-procedure prefix name))
  (void))

(define (build-target! prefix name built-results visiting)
  (define key (target-key name))
  (cond
    [(hash-has-key? built-results key)
     (hash-ref built-results key)]
    [(hash-has-key? visiting key)
     (error 'racket-makefile "dependency cycle involving target: ~a" key)]
    [else
     (unless (registered-target? prefix key)
       (error 'racket-makefile "unknown target ~a for makefile ~a" key prefix))

     (hash-set! visiting key #t)
     (define dependencies (dependencies-for prefix key))

     (for ([dependency (in-list dependencies)])
       (if (registered-target? prefix dependency)
           (build-target! prefix dependency built-results visiting)
           (unless (path-modify-seconds dependency)
             (error 'racket-makefile
                    "dependency does not exist and has no target: ~a"
                    dependency))))

     (define rebuilt? (needs-build? prefix key dependencies built-results))
     (when rebuilt?
       (execute-target! prefix key))

     (hash-remove! visiting key)
     (hash-set! built-results key rebuilt?)
     rebuilt?]))

(define (default-target-list prefix)
  (define pkey (prefix-key prefix))
  (cond
    [(hash-has-key? default-targets pkey)
     (list (hash-ref default-targets pkey))]
    [(pair? (hash-ref target-order pkey '()))
     (list (car (hash-ref target-order pkey)))]
    [else '()]))

(define (make-targets! . names)
  (define prefix (current-makefile-prefix))
  (unless prefix
    (error 'make "no current makefile prefix; evaluate a makefile definition first"))

  (define selected
    (if (null? names)
        (default-target-list prefix)
        (append-map target-keys names)))

  (when (null? selected)
    (error 'make "makefile ~a does not define a target" prefix))

  (define built-results (make-hash))
  (define visiting (make-hash))

  (for ([name (in-list selected)])
    (build-target! prefix name built-results visiting))
  (void))