(zilch lang ninja build): support per-project patches

lang/ninja/src/build.sld

@@ -6,7 +6,7 @@
   (zilch nixpkgs) (zilch zexpr) (zilch vfs)
   (chicken format)
   (srfi 128) (srfi 146) (srfi 152)
-  (zilch lang ninja))
+  (zilch lang ninja) (zilch lang ninja config))
 
  (export process-ninja-file)
 
@@ -42,7 +42,7 @@
       (string-map (lambda (c) (if (is-valid-store-path-char c) c #\-)) (if (> (string-length str) 211) (string-copy str 0 211) str))))
 
 
-  (define (derivation-for-edge environment vfs-store-path relative-to-root edges current-edge)
+  (define (derivation-for-edge conf vfs-store-path relative-to-root edges current-edge)
     (define resolved (build-edge-resolved current-edge))
     (when (build-rule-rspfile resolved) (error "rspfile not yet supported" current-edge))
     (define copy-input-files "")
@@ -96,17 +96,42 @@
     (for-each append-copy-command (build-edge-outputs current-edge))
     (for-each append-copy-command (build-edge-implicit-outputs current-edge))
 
+    (define patch-commands (list))
+    (for-each
+     (lambda (patch)
+      (define result (patch current-edge))
+      (when result
+        (set! patch-commands (cons result patch-commands))))
+     (ninja-build-config-patches conf))
+    (set! patch-commands (reverse patch-commands))
+    (define processed-patch-commands
+      #~,(string-join
+          (map
+           (lambda (item)
+            (if (string? item) item
+              (string-join item "\n")))
+           #$patch-commands)
+          "\n"))
+
     ; Run the build rule inside the build environment's vfs. This requires copying the entire VFS over, sadly.
     (define command
       #~,(string-append
+          ; Copy over the VFS, as we have to make changes to it.
           #$coreutils "/bin/cp -rf --no-preserve=ownership " #$vfs-store-path " bdir\n"
           #$coreutils "/bin/chmod ugo+rw -R bdir\n"
+
+          ; Copy over the other input files.
           "(COREUTILS=" #$coreutils "/bin; " #$copy-input-files ")\n"
-          "cd bdir/" relative-to-root "\n"
-          "(" command-to-run ") || exit 1\n"
-          "COREUTILS=" #$coreutils"/bin\n"
-          "$COREUTILS/mkdir " out-placeholder "\n"
-          #$copy-output-files))
+          #$coreutils "/bin/chmod ugo+rw -R bdir\n"
+
+          ; Run any patches we have received.
+          "(cd bdir; _ZILCH_ROOT=" #$vfs-store-path "; PATH=\"" #$coreutils "/bin:$PATH\"; " #$processed-patch-commands ")\n"
+
+          ; Enter the build dir and then run the command for this build.
+          "(cd bdir/" relative-to-root "; " command-to-run ") || exit 1\n"
+
+          ; Create the output directory, and copyy over the output files.
+          "(COREUTILS=" #$coreutils"/bin; cd bdir/" relative-to-root "; $COREUTILS/mkdir " out-placeholder "\n" #$copy-output-files ")"))
 
     ; Create the derivation. The rest of the code, that builds up the full list of edges, will extract each output from it.
     (define outpath
@@ -115,7 +140,7 @@
        (make-valid-store-path-string (build-rule-description resolved))
        "x86_64-linux"
        (list "/bin/sh" "-c" command)
-       environment
+       (ninja-build-config-environment conf)
        '("out"))))
     outpath)
 
@@ -125,8 +150,7 @@
   ;;
   ;; If the `environment` is a <derivation> or a <store-path>, it is considered
   ;; to be a nixpkgs-style derivation, the same way `nix-shell` works.
-  (define (process-ninja-file file vfs environment relative-to)
-    (when (or (derivation? environment) (store-path? environment)) (set! environment (environment-for-derivation environment)))
+  (define (process-ninja-file file conf relative-to)
     (unless (or (string=? relative-to "") (string-suffix? "/" relative-to)) (set! relative-to (string-append relative-to "/")))
 
     (define edges (mapping (make-default-comparator)))
@@ -140,11 +164,11 @@
         ((string-prefix? relative-to path) (set! path (string-copy path (string-length relative-to))))
         (else (set! path (string-append "../" path))))
        (set! edges (mapping-set! edges path 'base)))
-     (vfs-contents vfs))
-    (define vfs-store-path (vfs-to-store vfs))
+     (vfs-contents (ninja-build-config-root-dir conf)))
+    (define vfs-store-path (vfs-to-store (ninja-build-config-root-dir conf)))
     (for-each
      (lambda (edge)
-      (define processed (delay (derivation-for-edge environment vfs-store-path relative-to edges edge)))
+      (define processed (delay (derivation-for-edge conf vfs-store-path relative-to edges edge)))
       (if (build-edge-resolved edge)
         (for-each (lambda (v) (set! edges (mapping-set! edges v (delay #~,(string-append #$(force processed) "/" v)))))
           (append (build-edge-outputs edge) (build-edge-implicit-outputs edge)))

lang/ninja/src/config.sld

@@ -0,0 +1,59 @@
+(define-library (zilch lang ninja config)
+ (import
+  (scheme base) (scheme eval)
+  (zilch nixpkgs) (zilch vfs))
+
+ (export
+  ninja-build-config?
+  ninja-build-config-environment ninja-build-config-root-dir
+  ninja-build-config-patches ninja-build-config-targets
+
+  parse-ninja-config)
+
+ (begin
+   (define-record-type <ninja-build-config>
+    (make-ninja-build-config environment root-dir patches targets)
+    ninja-build-config?
+    (environment ninja-build-config-environment set-ninja-build-config-environment!)
+    (root-dir ninja-build-config-root-dir set-ninja-build-config-root-dir!)
+    (patches ninja-build-config-patches set-ninja-build-config-patches!)
+    (targets ninja-build-config-targets set-ninja-build-config-targets!))
+
+   (define (parse-config-inner conf data)
+    (cond
+     ((null? data) conf)
+     ((null? (cdr data)) (error "Expected even list of directives in Zilch Ninja config"))
+     (else
+      (case (car data)
+       ((#:env #:environment)
+        (set-ninja-build-config-environment! conf (if (string? (list-ref data 1)) (environment-for-derivation (cdar (nixpkgs-eval (list-ref data 1)))) (list-ref data 1)))
+        (parse-config-inner conf (cddr data)))
+       ((#:root)
+        (set-ninja-build-config-root-dir! conf (if (string? (list-ref data 1)) (vfs-from-directory (list-ref data 1)) (list-ref data 1)))
+        (parse-config-inner conf (cddr data)))
+       ((#:patch)
+        (let*
+         ((patch-base (list-ref data 1))
+          (processed-patch
+           (cond
+            ((string? patch-base)
+             (lambda (target) patch-base))
+            ((list? patch-base)
+             (eval patch-base (environment '(scheme base) '(zilch lang ninja))))
+            (else patch-base))))
+         (set-ninja-build-config-patches! conf (cons processed-patch (ninja-build-config-patches conf))))
+        (parse-config-inner conf (cddr data)))
+       ((#:target #:targets)
+        (when (eq? (ninja-build-config-targets conf) #f)
+          (set-ninja-build-config-targets! conf '()))
+        (let*
+         ((val (list-ref data 1))
+          (list-val (if (list? val) val (list val))))
+         (set-ninja-build-config-targets! conf (append list-val (ninja-build-config-targets conf))))
+        (parse-config-inner conf (cddr data)))
+       (else (error (string-append "Unknown directive " (symbol->string (car data)) " parsing Zilch Ninja config")))))))
+
+   (define (parse-ninja-config config)
+    (unless (list? config)
+     (error "expected Zilch Ninja config to be a list"))
+    (parse-config-inner (make-ninja-build-config #f #f '() #f) config))))