zilch/lang/ninja/src/build.sld

(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))))