diff --git a/lang/ninja/src/build.sld b/lang/ninja/src/build.sld new file mode 100644 index 0000000..1653b2f --- /dev/null +++ b/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 or a , 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)))) diff --git a/lang/ninja/zilch-lang-ninja.egg b/lang/ninja/zilch-lang-ninja.egg index 7c6a1cc..0f56f7c 100644 --- a/lang/ninja/zilch-lang-ninja.egg +++ b/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))))