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)
  (chicken format)
  (srfi 128) (srfi 146) (srfi 152)
  (zilch lang ninja) (zilch lang ninja config))

 (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 "..") (if (or (null? part-stack) (string=? (car part-stack) "") (string=? (car part-stack) "..")) (set! part-stack (cons ".." 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)
    (if (string=? "" str)
      "zilch-ninja"
      (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 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 "")
    (define (append-file path)
      (define input-file (mapping-ref edges path (lambda () (mapping-ref/default edges (normalize-path path) #f))))

      (cond
        ; if input-file is 'base, this is part of the base vfs; we don't filter that right now.
        ((eq? input-file 'base) #f)

        ; Phony rule; pass through the inputs literally.
        ((and (pair? input-file) (eq? (car input-file) 'phony)) (for-each append-file (cddr input-file)))

        ; This file is produced by another build edge. Add it to our input vfs.
        (input-file
          (let ((prev-copy-input-files copy-input-files))
            (set! copy-input-files #~,(string-append #$prev-copy-input-files "\n" "$COREUTILS/mkdir -p bdir/" relative-to-root "/$($COREUTILS/dirname " path "); $COREUTILS/cp -rf " #$(force input-file) " bdir/" relative-to-root "/" path))))

        (else
          (unless (string-prefix? "/nix/store" path)
            (error "Path doesn't exist as build edge" path))))

      ; Workaround for Meson not adding the .so as build dependency when linking, instead using a .symbols file.
      ; This makes sense, as it only relinks when symbols change, but it breaks the dependency link, and is the only
      ; place this happens in Ninja file processing.
      ; TODO: how does nix-ninja handle this?
      (when (string-suffix? ".so.symbols" path)
        (let ((index (string-contains path ".p/")))
          (append-file (string-copy path 0 index)))))

    ; 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 parent directories for each output (TODO: implicit outputs?)
    (for-each
      (lambda (path)
        (define prev-copy-input-files copy-input-files)
        (set! copy-input-files #~,(string-append #$prev-copy-input-files "\n" "$COREUTILS/mkdir -p bdir/" relative-to-root "/$($COREUTILS/dirname " path ")")))
      (build-edge-outputs current-edge))

    ; Create the 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))

    (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"
          #$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
     (cdar
      (store-path-for-ca-drv*
       (make-valid-store-path-string (build-rule-description resolved))
       "x86_64-linux"
       (list "/bin/sh" "-c" command)
       (ninja-build-config-environment conf)
       '("out"))))
    outpath)

  (define (phony-edge edges current-edge)
    (define copies (list))
    (define (process-input path)
     (define input-file (mapping-ref edges path (lambda () (mapping-ref/default edges (normalize-path path) #f))))
     (if (and (pair? input-file) (eq? (car input-file) 'phony))
       (for-each process-input (cddr input-file))
       (set! copies (cons #~,(string-append "mkdir -p \"$out/$(dirname " path ")\"; cp -rf " #$(force input-file) " $out/" path) copies))))
    (for-each process-input (build-edge-inputs current-edge))

    (define command
      #~,(string-join #$copies "\n"))

    (cdar
     (store-path-for-ca-drv*
      "zilch-ninja-phony-edge"
      "x86_64-linux"
      (list "/bin/sh" "-c" command)
      #~(("PATH" . ,(string-append #$coreutils "/bin")))
      '("out"))))


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

    ; 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))))
       (cond
        ((string=? relative-to "") #f)
        ((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 (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 conf vfs-store-path relative-to edges edge)))
      (define all-outputs (append (build-edge-outputs edge) (build-edge-implicit-outputs edge)))
      (if (build-edge-resolved edge)
        (for-each (lambda (v) (set! edges (mapping-set! edges v (delay #~,(string-append #$(force processed) "/" v)))))
          all-outputs)

        ; This edge is phony; mark the edge as having its outputs.
        (for-each (lambda (v) (set! edges (mapping-set! edges v (cons 'phony (cons edge (build-edge-inputs edge))))))
          all-outputs)))
     (build-file-build-edges file))

    (define edge-ref
     (lambda (path)
       (define edge (force (mapping-ref/default edges path #f)))
       (if (and (pair? edge) (eq? (car edge) 'phony))
         (phony-edge edges (cadr edge))
         edge)))
    (define defaults (build-file-default-targets file))
    (values edge-ref defaults))))