racket-makefile/main.rkt

#lang racket/base

(require racket
         (for-syntax racket/base
                     racket/list
                     racket/string
                     syntax/parse)
         "private/commands.rkt"
         "private/engine.rkt"
         git-cli
         package-zipper
         net/sendurl
         racket/string)

(provide makefile
         target
         deps
         phony
         default-target
         make
         current-makefile-prefix
         makefile-targets
         refresh-makefile
         run
         raco
         rm-f
         rm-rf
         cleanup
         list-dir/files
         list-files
         list-dirs
         $target
         $deps
         $<
         (all-from-out git-cli)
         (all-from-out package-zipper)
         (all-from-out net/sendurl)
         (all-from-out racket/string))

(define loaded-makefile #f)

(define (remember-makefile! path)
  (when path
    (set! loaded-makefile path))
  (void))

(define (refresh-makefile)
  (unless loaded-makefile
    (error 'refresh-makefile "no makefile definition has been evaluated"))

  (define source loaded-makefile)
  (define directory (or (path-only source) (current-directory)))
  (define refresh-source
    (make-temporary-file "racket-makefile-refresh~a.rkt" #f directory))

  (copy-file source refresh-source #t)
  (reset-makefiles!)

  (dynamic-wind
    void
    (λ ()
      (dynamic-require refresh-source #f))
    (λ ()
      (set! loaded-makefile source)
      (delete-file refresh-source)))
  (void))

(define (make . names)
  (apply make-targets! names))

(define-syntax $target
  (syntax-id-rules ()
    [$target
     (or (current-target)
         (error '$target "$target is only available while a target procedure is running"))]))

(define-syntax $deps
  (syntax-id-rules ()
    [$deps
     (or (current-dependencies)
         (error '$deps "$deps is only available while a target procedure is running"))]))

(define-syntax $<
  (syntax-id-rules ()
    [$<
     (or (current-first-dependency)
         (error '$< "$< is only available while a target procedure with dependencies is running"))]))

(define-syntax (target stx)
  (raise-syntax-error 'target "only valid inside makefile" stx))

(define-syntax (deps stx)
  (raise-syntax-error 'deps "only valid inside a target clause in makefile" stx))

(define-syntax (phony stx)
  (raise-syntax-error 'phony "only valid inside makefile" stx))

(define-syntax (default-target stx)
  (raise-syntax-error 'default-target "only valid inside makefile" stx))

(begin-for-syntax
  (struct target-spec (name-datum name-expression dependencies body source) #:transparent)

  (define (literal-name-datum stx who)
    (syntax-parse stx
      [id:id
       (syntax-e #'id)]
      [s:str
       (syntax-e #'s)]
      [((~datum quote) value)
       (define datum (syntax-e #'value))
       (unless (or (symbol? datum) (string? datum) (path? datum))
         (raise-syntax-error who "expected a symbol, string, or path target name" stx))
       datum]
      [_
       (raise-syntax-error
        who
        "target and makefile names must be literal identifiers, strings, paths, or quoted symbols"
        stx)]))

  (define (literal-expression stx who)
    (define datum (literal-name-datum stx who))
    #`(quote #,datum))

  (define (dependency-expression stx)
    (if (and (identifier? stx)
             (not (identifier-binding stx)))
        #`(quote #,(syntax-e stx))
        stx))

  (define (procedure-identifier context prefix target)
    (define name
      (string->symbol
       (format "makefile-target-~a-~a" prefix target)))
    (datum->syntax context name context context))

  (define (parse-target clause)
    (syntax-parse clause
      #:datum-literals (target deps)
      [(target name (deps dependency ...) body ...)
       (define datum (literal-name-datum #'name 'target))
       (target-spec datum
                    (literal-expression #'name 'target)
                    (map dependency-expression
                         (syntax->list #'(dependency ...)))
                    (syntax->list #'(body ...))
                    clause)]
      [(target name body ...)
       (define datum (literal-name-datum #'name 'target))
       (target-spec datum
                    (literal-expression #'name 'target)
                    '()
                    (syntax->list #'(body ...))
                    clause)]))
  )

(define-syntax (makefile stx)
  (syntax-parse stx
    #:datum-literals (target phony default-target)
    [(_ prefix clause ...)
     (define prefix-datum (literal-name-datum #'prefix 'makefile))
     (define prefix-expression #`(quote #,prefix-datum))
     (define clauses (syntax->list #'(clause ...)))

     (define targets '())
     (define phony-forms '())
     (define default-forms '())

     (for ([clause (in-list clauses)])
       (syntax-parse clause
         #:datum-literals (target phony default-target)
         [(target . _)
          (set! targets (append targets (list (parse-target clause))))]
         [(phony name ...)
          (define names
            (for/list ([name (in-list (syntax->list #'(name ...)))])
              (literal-expression name 'phony)))
          (set! phony-forms
                (append phony-forms
                        (list #`(mark-phony! #,prefix-expression #,@names))))]
         [(default-target name)
          (define name-expression (literal-expression #'name 'default-target))
          (set! default-forms
                (append default-forms
                        (list #`(set-default-target!
                                 #,prefix-expression
                                 #,name-expression))))]
         [_
          (raise-syntax-error
           'makefile
           "expected target, phony, or default-target clause"
           clause)]))

     (define target-definitions
       (for/list ([spec (in-list targets)])
         (define proc-id
           (procedure-identifier stx prefix-datum (target-spec-name-datum spec)))
         (define name-expression (target-spec-name-expression spec))
         (define dependencies (target-spec-dependencies spec))
         (define body (target-spec-body spec))
         #`(begin
             (define (#,proc-id)
               (call-target-procedure
                #,prefix-expression
                #,name-expression
                (λ ()
                  #,@body
                  (void))))
             (register-target!
              #,prefix-expression
              #,name-expression
              (list #,@dependencies)
              #,proc-id))))

     (define source (syntax-source stx))
     (define remember-source
       (if (path? source)
           #`(remember-makefile! (string->path #,(path->string source)))
           #'(void)))

     #`(begin
         #,remember-source
         (begin-makefile! #,prefix-expression)
         #,@target-definitions
         #,@phony-forms
         #,@default-forms
         ;; The last makefile definition evaluated is the active makefile.
         (current-makefile-prefix #,prefix-expression)
         (void))]))