racket-makefile/main.rkt

#lang racket/base

(require racket
         racket/splicing
         racket/stxparam
         (for-syntax racket/base
                     racket/stxparam
                     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-prefixes
         makefile-targets
         makefile-target-exists?
         makefile-target-procedure
         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-parameter makefile-prefix
  (λ (stx)
    (raise-syntax-error 'racket-makefile "only valid inside makefile" stx)))

(begin-for-syntax
  (define (makefile-prefix-expression stx)
    (define transformer (syntax-parameter-value #'makefile-prefix))
    (transformer stx))

  (define (makefile-prefix-datum stx)
    (define expression (makefile-prefix-expression stx))
    (syntax-parse expression
      [((~datum quote) value)
       (syntax-e #'value)]
      [_
       (raise-syntax-error
        'makefile
        "makefile prefix must be a quoted symbol or string"
        stx)]))

  (define (static-name-datum stx)
    (syntax-parse stx
      [((~datum quote) value)
       (define datum (syntax-e #'value))
       (unless (or (symbol? datum) (string? datum) (path? datum))
         (raise-syntax-error
          'target
          "quoted target name must be a symbol, string, or path"
          stx))
       datum]
      [_ #f]))

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

  (define (dynamic-target-expression prefix-expression name dependencies body)
    #`(let* ([target-name #,name]
             [target-procedure
              (procedure-rename
               (λ ()
                 (call-target-procedure
                  #,prefix-expression
                  target-name
                  (λ ()
                    #,@body
                    (void))))
               (string->symbol
                (format "makefile-target-~a-~a"
                        #,prefix-expression
                        target-name)))])
        (register-target!
         #,prefix-expression
         target-name
         (list #,@dependencies)
         target-procedure)
        (void))))

(define-syntax (target stx)
  (syntax-parse stx
    #:datum-literals (deps)
    [(_ name (deps dependency ...) body ...)
     (define prefix-expression (makefile-prefix-expression stx))
     (define prefix-datum (makefile-prefix-datum stx))
     (define static-name (static-name-datum #'name))
     (define dependencies (syntax->list #'(dependency ...)))
     (define body-list (syntax->list #'(body ...)))

     (if (and static-name
              (not (eq? (syntax-local-context) 'expression)))
         (let ([proc-id
                (procedure-identifier stx prefix-datum static-name)])
           #`(begin
               (define (#,proc-id)
                 (call-target-procedure
                  #,prefix-expression
                  name
                  (λ ()
                    body ...
                    (void))))
               (register-target!
                #,prefix-expression
                name
                (list dependency ...)
                #,proc-id)))
         (dynamic-target-expression
          prefix-expression
          #'name
          dependencies
          body-list))]

    [(_ name body ...)
     (define prefix-expression (makefile-prefix-expression stx))
     (define prefix-datum (makefile-prefix-datum stx))
     (define static-name (static-name-datum #'name))
     (define body-list (syntax->list #'(body ...)))

     (if (and static-name
              (not (eq? (syntax-local-context) 'expression)))
         (let ([proc-id
                (procedure-identifier stx prefix-datum static-name)])
           #`(begin
               (define (#,proc-id)
                 (call-target-procedure
                  #,prefix-expression
                  name
                  (λ ()
                    body ...
                    (void))))
               (register-target!
                #,prefix-expression
                name
                '()
                #,proc-id)))
         (dynamic-target-expression
          prefix-expression
          #'name
          '()
          body-list))]))

(define-syntax (deps stx)
  (raise-syntax-error 'deps "only valid as the dependency clause of target" stx))

(define-syntax (phony stx)
  (syntax-parse stx
    [(_ name ...)
     (define prefix-expression (makefile-prefix-expression stx))
     #`(mark-phony! #,prefix-expression name ...)]))

(define-syntax (default-target stx)
  (syntax-parse stx
    [(_ name)
     (define prefix-expression (makefile-prefix-expression stx))
     #`(set-default-target! #,prefix-expression name)]))

(define-syntax (makefile stx)
  (syntax-parse stx
    [(_ ((~datum quote) prefix) form ...)
     (define prefix-datum (syntax-e #'prefix))
     (unless (or (symbol? prefix-datum) (string? prefix-datum))
       (raise-syntax-error
        'makefile
        "prefix must be a quoted symbol or string"
        #'prefix))

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

     (with-syntax ([prefix-expression prefix-expression])
       #`(begin
           #,remember-source
           (begin-makefile! prefix-expression)
           (splicing-syntax-parameterize
               ([makefile-prefix (λ (stx) #'prefix-expression)])
             form ...)
           (current-makefile-prefix prefix-expression)
           (void)))]

    [(_ prefix form ...)
     (raise-syntax-error
      'makefile
      "prefix must be explicit, for example (makefile 'stuff ...)"
      #'prefix)]))