zilch-cli-ninja: make source' and diff' operate on rewrites

Change-Id: I6a6a69644e8984ec8400e13928c8ac0e14526ad1

cli/zilch-ninja.scm

@@ -54,7 +54,7 @@
 (define source (and (assoc 'source options) (cdr (assoc 'source options))))
 
 (define config-path (if (assoc 'config-file options) (cdr (assoc 'config-file options)) "zilch.scm"))
-(define config (parse-ninja-config config-path `(override-source: ,(and source (vfs-from-directory source)) ,@(call-with-input-file config-path read))))
+(define config (parse-ninja-config config-path (string=? (car args) "build")`(override-source: ,(and source (vfs-from-directory source)) ,@(call-with-input-file config-path read))))
 
 (when (and (ninja-build-config-depfile-path config) (file-exists? (ninja-build-config-depfile-path config)))
   (set-ninja-build-config-depfile! config (alist->mapping (make-default-comparator) (call-with-input-file (ninja-build-config-depfile-path config) read))))
@@ -75,14 +75,43 @@
      (else (loop (cdr rewrites)))))))
  options)
 
+(define (do-diff config source-override is-root)
+  (define-values (_ configured-drv _ _ _ _ _) (setup-ninja-environment config '()))
+  (define path (or source-override (ninja-build-config-override-source-path config) (and is-root "src")))
+  (define exit-status 0)
+  (when path
+    (let*-values
+      (((pid) (process-run "git"
+               (list "diff" "--no-index" "--"
+                (string-append (store-path-realised configured-drv) "/src")
+                path)))
+       ((pid normal-exit new-exit-status) (process-wait pid)))
+      (unless normal-exit (exit #f))
+      (set! exit-status (max exit-status new-exit-status))))
+  (for-each
+   (lambda (v)
+    (set! exit-status
+     (max exit-status
+      (do-diff (cdr v) #f #f))))
+   (ninja-build-config-rewrites config))
+  exit-status)
+
+(define (do-source config source-override is-root)
+  (define-values (_ configured-drv _ _ _ _ _) (setup-ninja-environment config '()))
+  (define path (or source-override (ninja-build-config-override-source-path config) (and is-root "src")))
+  (when path
+   (system* (string-append "cp -rf --no-preserve=ownership -T " (store-path-realised configured-drv) "/src " (qs path)))
+   (system* (string-append "chmod -R u+rw " (qs path))))
+  (for-each
+   (lambda (v)
+    (do-source (cdr v) #f #f))
+   (ninja-build-config-rewrites config)))
+
 (cond
  ((string=? (car args) "source")
-  (let*-values
+  (do-source config (and (pair? (cdr args)) (cadr args)) #t))
-   (((_ configured-drv _ _ _ _ _) (setup-ninja-environment config '()))
+ ((string=? (car args) "diff")
-    ((realised) (store-path-realised configured-drv))
+  (exit (= (do-diff config source #t) 0)))
-    ((path) (if (null? (cdr args)) "src" (cadr args))))
-   (system* (string-append "cp -rf --no-preserve=ownership " realised "/src " (qs path)))
-   (system* (string-append "chmod -R u+rw " (qs path)))))
  ((string=? (car args) "build")
   (if (null? (cdr args))
    (let ((output (build-nixpkgs-drv-reproducibly config)))
@@ -98,11 +127,5 @@
       (define built-target (edge-ref target))
       (printf "~A\t-> ~S\n" target (store-path-realised (force (built-edge-out-drv (cdr built-target))))))
      (cdr args)))))
- ((string=? (car args) "diff")
-  (let*-values
-   (((_ configured-drv _ _ _ _ _) (setup-ninja-environment config '()))
-    ((realised) (store-path-realised configured-drv))
-    ((path) (or source "src")))
-   (process-execute "git" (list "diff" "--no-index" "--" (string-append realised "/src") path))))
  (else
   (print-help (string-append "Unknown subcommand " (car args)))))

lang/ninja/src/config.sld

@@ -10,7 +10,8 @@
   <ninja-build-config> ninja-build-config?
   ninja-build-config-environment ninja-build-config-environment-drv
   ninja-build-config-root-dir ninja-build-config-patches ninja-build-config-targets
-  ninja-build-config-override-source ninja-build-config-depfile ninja-build-config-depfile-path
+  ninja-build-config-override-source ninja-build-config-override-source-path
+  ninja-build-config-depfile ninja-build-config-depfile-path
   ninja-build-config-disallow-elide ninja-build-config-rewrites
 
   set-ninja-build-config-root-dir! set-ninja-build-config-environment! set-ninja-build-config-depfile!
@@ -26,7 +27,7 @@
    ;; Represents a parsed Ninja build configuration.
    ;; See `parse-ninja-config` for the definition of these fields.
    (define-record-type <ninja-build-config>
-    (make-ninja-build-config environment environment-drv root-dir patches targets override-source depfile depfile-path disallow-elide rewrites)
+    (make-ninja-build-config environment environment-drv root-dir patches targets override-source override-source-path depfile depfile-path disallow-elide rewrites)
     ninja-build-config?
     (environment ninja-build-config-environment set-ninja-build-config-environment!)
     (environment-drv ninja-build-config-environment-drv set-ninja-build-config-environment-drv!)
@@ -34,6 +35,7 @@
     (patches ninja-build-config-patches set-ninja-build-config-patches!)
     (targets ninja-build-config-targets set-ninja-build-config-targets!)
     (override-source ninja-build-config-override-source set-ninja-build-config-override-source!)
+    (override-source-path ninja-build-config-override-source-path set-ninja-build-config-override-source-path!)
     (depfile ninja-build-config-depfile set-ninja-build-config-depfile!)
     (depfile-path ninja-build-config-depfile-path set-ninja-build-config-depfile-path!)
     (disallow-elide ninja-build-config-disallow-elide set-ninja-build-config-disallow-elide!)
@@ -46,7 +48,7 @@
         (string-append (string-copy path 0 last-slash) "/" path2)
         path2))))
 
-   (define (parse-config-inner path conf data)
+   (define (parse-config-inner path accept-override conf data)
     (cond
      ((null? data) conf)
      ((null? (cdr data)) (error "Expected even list of directives in Zilch Ninja config"))
@@ -58,19 +60,22 @@
            (set-ninja-build-config-environment! conf (environment-for-derivation drv))
            (set-ninja-build-config-environment-drv! conf (store-path-drv drv)))
          (set-ninja-build-config-environment! conf (list-ref data 1)))
-        (parse-config-inner path conf (cddr data)))
+        (parse-config-inner path accept-override 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 path conf (cddr data)))
+        (parse-config-inner path accept-override conf (cddr data)))
        ((#:override-source)
-        (set-ninja-build-config-override-source! conf (if (string? (list-ref data 1)) (vfs-from-directory (relative-to-file path (list-ref data 1))) (list-ref data 1)))
+        (when (string? (list-ref data 1))
-        (parse-config-inner path conf (cddr data)))
+         (set-ninja-build-config-override-source-path! conf (relative-to-file path (list-ref data 1))))
+        (when accept-override
+         (set-ninja-build-config-override-source! conf (if (string? (list-ref data 1)) (vfs-from-directory (relative-to-file path (list-ref data 1))) (list-ref data 1))))
+        (parse-config-inner path accept-override conf (cddr data)))
        ((#:depfile-path)
         (set-ninja-build-config-depfile-path! conf (relative-to-file path (list-ref data 1)))
-        (parse-config-inner path conf (cddr data)))
+        (parse-config-inner path accept-override conf (cddr data)))
        ((#:depfile)
         (set-ninja-build-config-depfile! conf (list-ref data 1))
-        (parse-config-inner path conf (cddr data)))
+        (parse-config-inner path accept-override conf (cddr data)))
        ((#:patch)
         (let*
          ((patch-base (list-ref data 1))
@@ -82,7 +87,7 @@
              (scheme-eval patch-base))
             (else patch-base))))
          (set-ninja-build-config-patches! conf (cons processed-patch (ninja-build-config-patches conf))))
-        (parse-config-inner path conf (cddr data)))
+        (parse-config-inner path accept-override conf (cddr data)))
        ((#:disallow-elide)
         (let*
          ((thunk (list-ref data 1))
@@ -92,7 +97,7 @@
              (scheme-eval thunk))
             (else thunk))))
          (set-ninja-build-config-disallow-elide! conf processed-thunk)) 
-        (parse-config-inner path conf (cddr data)))
+        (parse-config-inner path accept-override conf (cddr data)))
        ((#:target #:targets)
         (when (eq? (ninja-build-config-targets conf) #f)
           (set-ninja-build-config-targets! conf '()))
@@ -100,12 +105,12 @@
          ((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 path conf (cddr data)))
+        (parse-config-inner path accept-override conf (cddr data)))
        ((#:rewrite)
         (let*
          ((val (list-ref data 1)))
-         (set-ninja-build-config-rewrites! conf (cons (cons (car val) (parse-ninja-config path (cdr val))) (ninja-build-config-rewrites conf))))
+         (set-ninja-build-config-rewrites! conf (cons (cons (car val) (parse-ninja-config path accept-override (cdr val))) (ninja-build-config-rewrites conf))))
-        (parse-config-inner path conf (cddr data)))
+        (parse-config-inner path accept-override conf (cddr data)))
        (else (error (string-append "Unknown directive " (keyword->string (car data)) " parsing Zilch Ninja config")))))))
   
    ;; Parses a Zilch Ninja configuration file.
@@ -141,10 +146,11 @@
    ;;   name.
    ;;
    ;; `path` is the path this file was located at, used to resolve relative paths for depfiles.
-   (define (parse-ninja-config path config)
+   ;; `accept-override` specifies whether override-source arguments are processed.
+   (define (parse-ninja-config path accept-override config)
     (unless (list? config)
      (error "expected Zilch Ninja config to be a list"))
-    (parse-config-inner path (make-ninja-build-config #f #f #f '() #f #f #f #f #f '()) config))
+    (parse-config-inner path accept-override (make-ninja-build-config #f #f #f '() #f #f #f #f #f #f '()) config))
 
    ;; `source-paths`: mapping of original store path to virtual path.
    ;; `finalized-drv`: promise of a <finalized-drv>