(zilch lang ninja): support processing simple build scripts

lang/ninja/src/build.sld

@@ -0,0 +1,119 @@
+(define-library (zilch lang ninja build)
+ (import
+  (scheme base) (scheme lazy)
+  (zilch file) (zilch magic) (scheme char)
+  (zilch nix drv) (zilch nix path)
+  (zilch nixpkgs) (zilch zexpr) (zilch vfs)
+  (srfi 128) (srfi 146) (srfi 152)
+  (zilch lang ninja))
+
+ (export process-ninja-file)
+
+ (begin
+  (define coreutils (cdr (assoc "out" (nixpkgs "coreutils"))))
+
+  ;; normalize a POSIX-y path. Ninja doesn't have an internal concept of path normalisation,
+  ;; so this is necessary for proper file-finding behavior.
+  (define (normalize-path path)
+    (define parts (string-split path "/"))
+    (define part-stack '())
+    (for-each
+      (lambda (part)
+        (cond
+          ((string=? part "") (when (null? part-stack) (set! part-stack '(""))))
+          ((string=? part "..") (unless (or (null? part-stack) (string=? (car part-stack) "")) (set! part-stack (cdr part-stack))))
+          ((string=? part "."))
+          (else (set! part-stack (cons part part-stack)))))
+      parts)
+    (string-join (reverse part-stack) "/"))
+
+  (define (is-valid-store-path-char c)
+    (or
+     (and (char>=? c #\0) (char<=? c #\9))
+     (and (char>=? c #\a) (char<=? c #\z))
+     (and (char>=? c #\A) (char<=? c #\Z))
+     (member c '(#\+ #\- #\. #\_ #\? #\=))))
+
+  ;; Helper to render nicer derivation names.
+  (define (make-valid-store-path-string str)
+    (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 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 (append-file path)
+      (define input-file (mapping-ref edges path (lambda () (mapping-ref/default edges (normalize-path path) #f))))
+
+      ; if input-file is 'base, this is part of the base vfs; we don't filter that right now.
+      (unless (eq? input-file 'base)
+        (if input-file
+          ; This file is produced by another build edge. Add it to our input vfs.
+          (set! vfs (vfs-append-file vfs (normalize-path path) (force input-file)))
+          (error "Path doesn't exist as build edge" path))))
+
+    ; Add the inputs, implicit dependencies, _and_ order-only dependencies to our vfs.
+    (for-each append-file (build-edge-inputs current-edge))
+    (for-each append-file (build-edge-implicit-dependencies current-edge))
+    (for-each append-file (build-edge-order-only-dependencies current-edge))
+
+    ; Create the VFS.
+    (define input-store-path (vfs-to-store vfs))
+    (define command-to-run (build-rule-command resolved))
+
+    ; For each output and implicit output, copy them to the derivation's output.
+    (define copy-output-files "")
+    (define out-placeholder (make-placeholder "out"))
+    (define (append-copy-command outpath)
+      (set! copy-output-files (string-append copy-output-files "\n" "$COREUTILS/mkdir -p " out-placeholder "/$($COREUTILS/dirname " outpath "); $COREUTILS/cp -rf " outpath " " out-placeholder "/" outpath)))
+    (for-each append-copy-command (build-edge-outputs current-edge))
+    (for-each append-copy-command (build-edge-implicit-outputs current-edge))
+
+    ; Run the build rule inside the build environment's vfs. This requires copying the entire VFS over, sadly.
+    (define command
+      #~,(string-append
+          #$coreutils "/bin/cp -rf --no-preserve=ownership " #$input-store-path " bdir\n"
+          #$coreutils "/bin/chmod ugo+rw -R bdir\ncd bdir/" relative-to-root "\n"
+          "(" command-to-run ") || exit 1\n"
+          "COREUTILS=" #$coreutils"/bin\n"
+          "$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
+     (cdar
+      (store-path-for-ca-drv*
+       (make-valid-store-path-string (build-rule-description resolved))
+       "x86_64-linux"
+       (list "/bin/sh" "-c" command)
+       environment
+       '("out"))))
+    outpath)
+
+  ;; process a ninja file and corresponding vfs, and return two values:
+  ;; - `edge-ref`, a lambda that lets one fetch any build edge;
+  ;; - `defaults`, a list containing the default build edges.
+  ;;
+  ;; 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 edges (mapping (make-default-comparator)))
+
+    ; record edges for each path in the base vfs.
+    (mapping-for-each
+     (lambda (kv path)
+       (define path (if (string=? (car kv) "") (cdr kv) (string-append (car kv) "/" (cdr kv))))
+       (set! edges (mapping-set! edges path 'base)))
+     (vfs-contents vfs))
+    (for-each
+     (lambda (edge)
+      (define processed (delay (derivation-for-edge environment vfs relative-to edges 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))))
+     (build-file-build-edges file))
+
+    (define edge-ref (lambda (path) (force (mapping-ref/default edges path #f))))
+    (define defaults (build-file-default-targets file))
+    (values edge-ref defaults))))

lang/ninja/zilch-lang-ninja.egg

@@ -6,4 +6,7 @@
   (csc-options "-X" "r7rs" "-X" "zilch.zexpr" "-R" "r7rs" "-optimize-level" "3"))
  (components
   (extension zilch.lang.ninja
-    (source "src/ninja.sld"))))
+    (source "src/ninja.sld"))
+  (extension zilch.lang.ninja.build
+    (source "src/build.sld")
+    (component-dependencies zilch.lang.ninja))))