zilch/lang/ninja/src/ninja.sld

(define-library (zilch lang ninja)
 (import
  (scheme base) (scheme write) (scheme process-context) (scheme lazy)
  (zilch file) (zilch magic) (zilch nix drv) (zilch nix path) (scheme char)
  (zilch nixpkgs) (zilch zexpr) (zilch semver)
  json
  (chicken process)
  (chicken base) (chicken format)
  (chicken foreign)
  (srfi 4) (srfi 128) (srfi 146) (srfi 152) (srfi 207))

 (export
  <build-file> make-build-file build-file?
  build-file-global-variables build-file-default-targets build-file-rules build-file-build-edges
  build-file-pools

  <build-rule> make-build-rule build-rule?
  build-rule-name build-rule-command build-rule-depfile build-rule-deps build-rule-description
  build-rule-restat build-rule-rspfile build-rule-rspfile-content

  <build-edge> make-build-edge build-edge?
  build-edge-rule build-edge-outputs build-edge-inputs
  build-edge-implicit-dependencies build-edge-order-only-dependencies build-edge-validations
  build-edge-implicit-outputs build-edge-variables build-edge-resolved

  read-ninja-file)

 (begin
   ;; Write a properly escaped string to the provided port.
   (define (write-variable-string port var as-path)
    (string-for-each
     (lambda (c)
      (cond
       ((and as-path (member c '(#\space #\: #\$))) (write-char #\$ port))
       ((char=? c #\newline) (write-char #\$ port)))
      (write-char c port)
      (when (char=? c #\newline) (write-string "  " port)))
     var))

   ;; Writes a variable, prefixed with $ and curly-bracketed, to a port.
   (define (write-variable port var)
     (write-string (string-append "${" var "}") port))

   ;; Returns a string containing the contents of the evalstring, properly escaped.
   (define (render-evalstring var as-path)
     (define out (open-output-string))
     (for-each
      (lambda (chunk)
       (cond
        ((string? chunk) (write-variable-string out chunk as-path))
        ((pair? chunk) (write-variable out (cdr chunk))))) (if (string? var) (list var) var))
     (define str (get-output-string out))
     (close-output-port out)
     str)

   (define (is-valid-varname-char ch simple)
     (or
       (and (char>=? ch #\a) (char<=? ch #\z))
       (and (char>=? ch #\A) (char<=? ch #\Z))
       (and (char>=? ch #\0) (char<=? ch #\9))
       (char=? ch #\_) (char=? ch #\-)
       (and (not simple) (char=? ch #\.))))
   (define (is-valid-varname-byte ch simple)
     (or
       (and (>= ch #x61) (<= ch #x7A))
       (and (>= ch #x41) (<= ch #x5A))
       (and (>= ch #x30) (<= ch #x39))
       (= ch #x5F) (= ch #x2D)
       (and (not simple) (= ch #x2E))))

   (define (is-valid-eval-string-char ch path)
     (not
       (or
         (char=? ch #\null)
         (char=? ch #\newline)
         (char=? ch #\return)
         (char=? ch #\$)
         (and path
          (or
           (char=? ch #\space)
           (char=? ch #\:)
           (char=? ch #\|))))))

   (define (is-valid-eval-string-byte ch path)
     (not
       (or
         (= ch 0)
         (= ch #x0A)
         (= ch #x0D)
         (= ch #x24)
         (and path
          (or
           (= ch #x20)
           (= ch #x3A)
           (= ch #x7C))))))

   (define (resolve-evalstring evalstr file rule edge is-command)
     (define (find-value val)
       (define res #f)
       (when edge
         (cond
           ((string=? val "in") (set! res (string-join (build-edge-inputs edge))))
           ((string=? val "in_newline") (set! res (string-join (build-edge-inputs edge) "\n")))
           ((string=? val "out") (set! res (string-join (build-edge-outputs edge))))
           (else (set! res (mapping-ref/default (build-edge-variables edge) val #f)))))
       (when rule
         (cond
           ((member val '("command" "depfile" "deps" "msvc_deps_prefix" "description" "dyndep" "generator" "restat" "rspfile" "rspfile_content") string=?) (error "ambiguity in how to process build rules depending on build rules!"))))
       (unless res
         (set! res
           (mapping-ref/default (build-file-global-variables file) val "")))
       res)
     (apply string-append
      (map
       (lambda (part)
        (if (string? part)
            part
            (find-value (cdr part))))
       evalstr)))

   (define (pr out name value) (unless (eq? value #f) (fprintf out "  ~A = ~A\n" name (render-evalstring value #f))))

   ;; Represents a Ninja build file.
   (define-record-type <build-file>
     (make-build-file global-variables default-targets rules build-edges pools)
     build-file?
     (global-variables build-file-global-variables set-build-file-global-variables!)
     (default-targets build-file-default-targets set-build-file-default-targets!)
     (rules build-file-rules set-build-file-rules!)
     (build-edges build-file-build-edges set-build-file-build-edges!)
     (pools build-file-pools set-build-file-pools!))

   (define-record-printer (<build-file> file out)
     (fprintf out "# debug build file\n")
     (mapping-for-each (lambda (k v) (fprintf out "~A = ~A\n" k (render-evalstring v #f))) (build-file-global-variables file))
     (unless (null? (build-file-default-targets file))
       (fprintf out "default")
       (for-each (lambda (v) (fprintf out " ~A" (render-evalstring v #t))) (build-file-default-targets file))
       (fprintf out "\n"))
     (mapping-for-each (lambda (k rule) (fprintf out "~S" rule)) (build-file-rules file))
     (for-each (lambda (edge) (fprintf out "~S" edge)) (build-file-build-edges file)))

   ;; Represents a Ninja build rule.
   ; variables that are ignored for now: dyndep, generator, pool, msvc_deps_prefix
   (define-record-type <build-rule>
     (make-build-rule name command depfile deps description restat rspfile rspfile-content)
     build-rule?
     (name build-rule-name set-build-rule-name!)
     (command build-rule-command set-build-rule-command!)
     (depfile build-rule-depfile set-build-rule-depfile!)
     (deps build-rule-deps set-build-rule-deps!)
     (description build-rule-description set-build-rule-description!)
     (restat build-rule-restat set-build-rule-restat!)
     (rspfile build-rule-rspfile set-build-rule-rspfile!)
     (rspfile-content build-rule-rspfile-content set-build-rule-rspfile-content!))

   (define-record-printer (<build-rule> rule out)
     (fprintf out "rule ~A\n" (build-rule-name rule))
     (pr out "command" (build-rule-command rule))
     (pr out "depfile" (build-rule-depfile rule))
     (pr out "deps" (build-rule-deps rule))
     (pr out "description" (build-rule-description rule))
     (pr out "restat" (build-rule-restat rule))
     (pr out "rspfile" (build-rule-rspfile rule))
     (pr out "rspfile-content" (build-rule-rspfile-content rule))
     (fprintf out "\n"))

   ;; Represents a Ninja build edge (aka one or more files built by this Ninja file)
   (define-record-type <build-edge>
     (make-build-edge rule outputs inputs implicit-dependencies order-only-dependencies validations implicit-outputs variables resolved)
     build-edge?
     (rule build-edge-rule)
     (outputs build-edge-outputs)
     (inputs build-edge-inputs)
     (implicit-dependencies build-edge-implicit-dependencies)
     (order-only-dependencies build-edge-order-only-dependencies)
     (validations build-edge-validations)
     (implicit-outputs build-edge-implicit-outputs)
     (variables build-edge-variables set-build-edge-variables!)
     (resolved build-edge-resolved set-build-edge-resolved!))
   (define-record-printer (<build-edge> edge out)
     (fprintf out "build")
     (for-each (lambda (var) (fprintf out " ~A" (render-evalstring var #t))) (build-edge-outputs edge))
     (fprintf out ": ~A" (build-edge-rule edge))
     (for-each (lambda (var) (fprintf out " ~A" (render-evalstring var #t))) (build-edge-inputs edge))
     (unless (null? (build-edge-implicit-dependencies edge))
       (fprintf out " |")
       (for-each (lambda (var) (fprintf out " ~A" (render-evalstring var #t))) (build-edge-implicit-dependencies edge)))
     (unless (null? (build-edge-order-only-dependencies edge))
       (fprintf out " ||")
       (for-each (lambda (var) (fprintf out " ~A" (render-evalstring var #t))) (build-edge-order-only-dependencies edge)))
     (unless (null? (build-edge-validations edge))
       (fprintf out " |@")
       (for-each (lambda (var) (fprintf out " ~A" (render-evalstring var #t))) (build-edge-validations edge)))
     (fprintf out "\n")
     (mapping-for-each (lambda (k v) (pr out k v)) (build-edge-variables edge))
     (define rule (build-edge-resolved edge))
     (when rule
       (fprintf out "  resolved rule ~A\n" (build-rule-name rule))
       (pr out "  command" (build-rule-command rule))
       (pr out "  depfile" (build-rule-depfile rule))
       (pr out "  deps" (build-rule-deps rule))
       (pr out "  description" (build-rule-description rule))
       (pr out "  restat" (build-rule-restat rule))
       (pr out "  rspfile" (build-rule-rspfile rule))
       (pr out "  rspfile-content" (build-rule-rspfile-content rule))
       (fprintf out "\n"))
     (fprintf out "\n"))
   (define (build-rule-resolve rule edge file)
     (define (try-resolve v is-command)
       (and v (resolve-evalstring v file rule edge is-command)))
     (make-build-rule #f
        (try-resolve (build-rule-command rule) #t)
        (try-resolve (build-rule-depfile rule) #f)
        (try-resolve (build-rule-deps rule) #f)
        (try-resolve (build-rule-description rule) #f)
        (try-resolve (build-rule-restat rule) #f)
        (try-resolve (build-rule-rspfile rule) #f)
        (try-resolve (build-rule-rspfile-content rule) #f)))
  
   (define (bytevector-prefix? bv in-bv index)
     (define bv-len (bytevector-length bv))
     (define (inner-loop j)
       (cond
         ((>= j bv-len) #t)
         ((= (bytevector-u8-ref bv j) (bytevector-u8-ref in-bv (+ index j)))
          (inner-loop (+ j 1)))
         (else #f)))
     (if (> (+ index bv-len) (bytevector-length in-bv))
       #f
       (inner-loop 0)))
  
   ;; Reads a full Ninja file, returning a <build-file> record.
   (define (read-ninja-file strval)
    (define i 0)
    (define (eat-whitespace)
      (cond
       ((>= i (bytevector-length strval)))
       ((bytevector-prefix? #u8(#x24 #x0D #x0A) strval i) (set! i (+ i 3)) (eat-whitespace))
       ((bytevector-prefix? #u8(#x24 #x0A) strval i) (set! i (+ i 2)) (eat-whitespace))
       ((= (bytevector-u8-ref strval i) #x20) (set! i (bytestring-index strval (lambda (ch) (not (= ch #x20))) i)) (eat-whitespace))))
    (define (read-eval-string-text path)
     (define collected '())
     (define start-i i)
     (define (tick)
      (cond
       ((>= i (bytevector-length strval)) (error "unexpected EOF"))
       ((is-valid-eval-string-byte (bytevector-u8-ref strval i) path)
        (let ((start-i i))
          (do () ((or (>= i (bytevector-length strval)) (not (is-valid-eval-string-byte (bytevector-u8-ref strval i) path))))
            (set! i (+ i 1)))
          (set! collected (cons (utf8->string strval start-i i) collected)))
        (tick))
       ((and path (member (bytevector-u8-ref strval i) '(#x20 #x3A #x7C #x0A))))
       ((and (not path) (= #x0A (bytevector-u8-ref strval i)))
        (set! i (+ i 1)))
       ((bytevector-prefix? #u8(#x0D #x0A) strval i)
        (unless path
          (set! i (+ i 2))))
       ((bytevector-prefix? #u8(#x24 #x0D #x0A) strval i)
        (set! i (bytestring-index strval (lambda (ch) (not (= ch #x20))) (+ i 3)))
        (tick))
       ((bytevector-prefix? #u8(#x24 #x0A) strval i)
        (set! i (bytestring-index strval (lambda (ch) (not (= ch #x20))) (+ i 2)))
        (tick))
       ((bytevector-prefix? #u8(#x24 #x7B) strval i)
        (let ((end-of-varname (bytestring-index strval (lambda (ch) (not (is-valid-varname-byte ch #f))) (+ i 2))))
             (unless (= (bytevector-u8-ref strval end-of-varname) #x7D) (error "unexpected non-varname character at index" end-of-varname))
             (set! collected (cons (cons 'varname (utf8->string strval (+ i 2) end-of-varname)) collected))
             (set! i (+ end-of-varname 1)))
        (tick))
       ((or (bytevector-prefix? #u8(#x24 #x24) strval i) (bytevector-prefix? #u8(#x24 #x3A) strval i) (bytevector-prefix? #u8(#x24 #x20) strval i))
        (set! collected (cons (utf8->string strval (+ i 1) (+ i 2)) collected))
        (set! i (+ i 2))
        (tick))
       ((and (= (bytevector-u8-ref strval i) #x24) (is-valid-varname-byte (bytevector-u8-ref strval (+ i 1)) #t))
        (let ((end-of-varname (bytestring-index strval (lambda (ch) (not (is-valid-varname-byte ch #t))) (+ i 1))))
             (set! collected (cons (cons 'varname (utf8->string strval (+ i 1) end-of-varname)) collected))
             (set! i end-of-varname))
        (tick))
       ((= (bytevector-u8-ref strval i) #x24)
        (error "bad $-escape at index" i))
       (else (error "Unknown character at index" i))))
     (tick)
     (when path (eat-whitespace))
     (if (= i start-i) #f (reverse collected)))

    (define (try-read-eval-string-text path)
     (define start-i i)
     (call/cc
      (lambda (cc)
       (with-exception-handler
        (lambda (h) (set! i start-i) (cc #f))
        (lambda () (read-eval-string-text path))))))

    (define (read-token)
     (define start-i i)
     (define post-space (or (bytestring-index strval (lambda (ch) (not (= ch #x20))) i) i))
     (define token
      (cond
       ((>= i (bytevector-length strval))
        'eof)
       ((bytevector-prefix? #u8(#x23) strval post-space)
        (let ((end-of-comment (or (bytestring-index strval (lambda (ch) (= ch #x0A)) post-space) (bytevector-length strval))))
          (set! i end-of-comment)
          (read-token)))
       ((bytevector-prefix? #u8(#x0D #x0A) strval post-space)
        (set! i (+ post-space 2))
        'newline)
       ((bytevector-prefix? #u8(#x0A) strval post-space)
        (set! i (+ post-space 1))
        'newline)
       ((> post-space i)
        'indent)
       ((= (bytevector-u8-ref strval i) #x3D)
        (set! i (+ i 1))
        'equals)
       ((= (bytevector-u8-ref strval i) #x3A)
        (set! i (+ i 1))
        'colon)
       ((bytevector-prefix? #u8(#x7C #x40) strval i)
        (set! i (+ i 2))
        'pipe-at)
       ((bytevector-prefix? #u8(#x7C #x7C) strval i)
        (set! i (+ i 2))
        'pipe-pipe)
       ((= (bytevector-u8-ref strval i) #x7C)
        (set! i (+ i 1))
        'pipe)
       ((is-valid-varname-byte (bytevector-u8-ref strval i) #f)
        (let* ((token-end (bytestring-index strval (lambda (ch) (not (is-valid-varname-byte ch #f))) i))
               (token (utf8->string strval i token-end)))
          (set! i token-end)
          (cond
             ((string=? token "build") 'build)
             ((string=? token "pool") 'pool)
             ((string=? token "rule") 'rule)
             ((string=? token "default") 'default)
             ((string=? token "include") 'include)
             ((string=? token "subninja") 'subninja)
             (else token))))
       (else #f)))
     (unless (member token '(newline eof #f)) (eat-whitespace))
     token)
    (define (expect-token expected)
     (define prev-i i)
     (define token (read-token))
     (if (eqv? expected token)
       token
       (begin (set! i prev-i) #f)))

    (define (read-rule)
      (define name (read-token))
      (unless (string? name) (error "reading rule: expected valid ident, found" name))
      (unless (expect-token 'newline) (error "reading rule: expected name to be followed by newline"))
      (define rule (make-build-rule name #f #f #f #f #f #f #f))
      (define (parse-variable)
        (define name #f)
        (define contents #f)
        (when (expect-token 'indent)
         (set! name (read-token))
         (unless (string? name) (error "reading rule: expected name, found" name))
         (unless (expect-token 'equals) (error "reading rule: expected equals, found" (read-token)))
         (set! contents (read-eval-string-text #f))
         (cond
            ((string=? name "command") (set-build-rule-command! rule contents))
            ((string=? name "depfile") (set-build-rule-depfile! rule contents))
            ((string=? name "deps") (set-build-rule-deps! rule contents))
            ((string=? name "description") (set-build-rule-description! rule contents))
            ((string=? name "restat") (set-build-rule-restat! rule contents))
            ((string=? name "rspfile") (set-build-rule-rspfile! rule contents))
            ((string=? name "rspfile_content") (set-build-rule-rspfile-content! rule contents))
            ((member name '("dyndep" "generator" "pool" "msvc_deps_prefix") string=?))
            (else (error "reading rule: unexpected rule" name)))
         (parse-variable)))
      (parse-variable)
      rule)

    (define (read-pool)
      (define name (read-token))
      (unless (string? name) (error "reading pool: expected valid ident, found" name))
      (unless (expect-token 'newline) (error "reading pool: expected name to be followed by newline"))
      (define (parse-variable)
        (define name #f)
        (define contents #f)
        (when (expect-token 'indent)
         (set! name (read-token))
         (unless (string? name) (error "reading pool: expected name, found" name))
         (unless (expect-token 'equals) (error "reading poolo: expected equals, found" (read-token)))
         (set! contents (read-eval-string-text #f))
         (parse-variable)))
      (parse-variable))

    (define (read-build-edge file)
      (define (read-list tail)
        (define eval-string (try-read-eval-string-text #t))
        (if eval-string
          (read-list (cons (resolve-evalstring eval-string file #f #f #f) tail))
          (reverse tail)))

      (define outputs (read-list '()))
      (define implicit-outputs '())
      (when (expect-token 'pipe)
        (set! implicit-outputs (read-list '())))
      (unless (expect-token 'colon)
        (error "reading build edge: expected colon, found" (read-token)))
      (define rule-name (read-token))
      (unless (string? rule-name)
        (error "reading build edge: expected rule name, found" rule-name))
      (define inputs (read-list '()))
      (define implicit-dependencies '())
      (when (expect-token 'pipe)
        (set! implicit-dependencies (read-list '())))
      (define order-only-dependencies '())
      (when (expect-token 'pipe-pipe)
        (set! order-only-dependencies (read-list '())))
      (define validations '())
      (when (expect-token 'pipe-at)
        (set! validations (read-list '())))
      (unless (expect-token 'newline) (error "reading build edge: expected rule name / dependencies to be followed by newline"))
      (define edge (make-build-edge rule-name outputs inputs implicit-dependencies order-only-dependencies validations implicit-outputs (mapping (make-default-comparator)) #f))
      (define (parse-variable)
        (define name #f)
        (define contents #f)
        (when (expect-token 'indent)
         (set! name (read-token))
         (when (eq? name 'pool) (set! name "pool")) ; uh. how is this supposed to work

         (unless (string? name) (error "reading build edge var: expected name, found" name))
         (unless (expect-token 'equals) (error "reading build edge var: expected equals, found" (read-token)))
         (set! contents (resolve-evalstring (read-eval-string-text #f) file #f #f #f))
         (set-build-edge-variables! edge (mapping-set! (build-edge-variables edge) name contents))
         (parse-variable)))
      (parse-variable)
      edge)

    (define (read-toplevel file)
      (define token (read-token))
      (case token
       ((eof) #f)
       ((rule)
        (let ((rule (read-rule))) (set-build-file-rules! file (mapping-set! (build-file-rules file) (build-rule-name rule) rule)))
        (read-toplevel file))
       ((build)
        (let ((edge (read-build-edge file))) (set-build-file-build-edges! file (cons edge (build-file-build-edges file))))
        (read-toplevel file))
       ((default)
        (do () ((expect-token 'newline)) (set-build-file-default-targets! file (cons (resolve-evalstring (read-eval-string-text #t) file #f #f #f) (build-file-default-targets file)))))
       ((subninja include) (error "todo: includes"))
       ((pool) (read-pool) (read-toplevel file))
       ((newline) (read-toplevel file))
       (else
         (unless (string? token) (error "unexpected" (list token i)))
         (unless (expect-token 'equals) (error "expected =, found" (read-token)))
         (let* ((value (read-eval-string-text #f)) (resolved (resolve-evalstring value file #f #f #f)))
           (set-build-file-global-variables! file (mapping-set! (build-file-global-variables file) token resolved)))
         (read-toplevel file)))
      file)
    (define out-file (read-toplevel (make-build-file (mapping (make-default-comparator)) '() (mapping (make-default-comparator)) '() (mapping (make-default-comparator)))))
    (for-each (lambda (f) (unless (string=? (build-edge-rule f) "phony") (set-build-edge-resolved! f (build-rule-resolve (mapping-ref (build-file-rules out-file) (build-edge-rule f)) f out-file)))) (build-file-build-edges out-file))
    out-file)))