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
   built-edge-edge built-edge-out-drv
   built-edge-lib-placeholder built-edge-phony-inputs)

 (begin
  (define coreutils (cdr (assoc "out" (nixpkgs "coreutils"))))
  (define patchelf (cdr (assoc "out" (nixpkgs "patchelf"))))
  (define llvm-bintools (cdr (assoc "out" (nixpkgs-eval "llvmPackages_latest.bintools-unwrapped"))))

  (define-record-type <built-edge>
    (make-built-edge edge out-drv lib-placeholder phony-inputs)
    built-edge?
    (edge built-edge-edge)
    (out-drv built-edge-out-drv)
    (lib-placeholder built-edge-lib-placeholder)
    (phony-inputs built-edge-phony-inputs))

  (define-record-type <build-env>
    (make-build-env config vfs build-dir)
    build-env?
    (config build-env-config)
    (vfs build-env-vfs)
    (build-dir build-env-build-dir))

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

  ;; Returns a derivation that runs the command for this edge,
  ;; inside a Nix derivation with the correct inputs.
  (define (derivation-for-edge env 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 is-meson-phony #f)

    ; Appends a single input to the input of this edge's build command.
    (define (append-file path)
      ; Normalize paths pointing into the build environment.
      (cond
       ((string-prefix? "/build/bdir/src/" path)
        (set! path (string-append "../" (string-copy path 12))))
       ((string-prefix? "/build/bdir/build/" path)
        (set! path (string-copy path 18))))
      (define input (mapping-ref edges path (lambda () (mapping-ref/default edges (normalize-path path) #f))))

      (define input-file (and input (car input)))
      (define input-edge (and input (force (cdr input))))

      (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.
        ((eq? input-file 'phony) (for-each append-file (built-edge-phony-inputs input-edge)))

        ; 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/" (build-env-build-dir env) "/$($COREUTILS/dirname " path "); $COREUTILS/cp -rf " #$(force input-file) " bdir/" (build-env-build-dir env) "/" path))))

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

      ; Workaround for Meson not adding the .so as build dependency when linking, instead using a .symbols file.
      ; To replicate Meson's behavior, we use a .so stub generated when a .so.symbols path is seen; this serves
      ; the same purpose.
      (when (and input-edge (built-edge-lib-placeholder input-edge))
        (let* ((pair (force (built-edge-lib-placeholder input-edge)))
               (so-path (car pair))
               (so-file (cdr pair)))
         (let ((prev-copy-input-files copy-input-files))
          (set! copy-input-files #~,(string-append #$prev-copy-input-files "\n" "$COREUTILS/mkdir -p bdir/" (build-env-build-dir env) "/$($COREUTILS/dirname " so-path "); $COREUTILS/cp -rf " #$so-file " bdir/" (build-env-build-dir env) "/" so-path)))))

      ; Make sure we have all .so stubs transitively.
      (when
       (and input-edge (built-edge-lib-placeholder input-edge))
       ; Depend on all .so.symbols files from the input's edge's dependencies too.
       (let*
        ((so-path (car (build-edge-inputs (built-edge-edge input-edge))))
         (recursive-drv (mapping-ref edges so-path (lambda () (mapping-ref edges (normalize-path so-path)))))
         (so-edge (built-edge-edge (force (cdr recursive-drv)))))
        (for-each
         (lambda (input)
          (when (string-suffix? ".so.symbols" input)
            (append-file input)))
         (append (build-edge-inputs so-edge) (build-edge-implicit-dependencies so-edge) (build-edge-order-only-dependencies so-edge)))))

      (when (string=? path "PHONY")
       (set! is-meson-phony #t)))

    ; 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/" (build-env-build-dir env) "/$($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)
      (if is-meson-phony
       (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 " || true"))
       (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 (build-env-config env)))
    (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 " #$(build-env-vfs env) " 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=" #$(build-env-vfs env) "; PATH=\"" #$coreutils "/bin:$PATH\"; " #$processed-patch-commands ")\n"

          ; Enter the build dir and then run the command for this build.
          "(cd bdir/" (build-env-build-dir env) "; " command-to-run ") || exit 1\n"

          ; Create the output directory, and copyy over the output files.
          "(COREUTILS=" #$coreutils"/bin; cd bdir/" (build-env-build-dir env) "; $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"
       '("/bin/sh" "-c" "exec /bin/sh $ZILCH_CMDPath")
       `(("ZILCH_CMD" . ,command) ("passAsFile" . "ZILCH_CMD") . ,(ninja-build-config-environment (build-env-config env)))
       '("out"))))
    outpath)
  (define (ifs-for-shsym env edges current-edge)
    (define implib (mapping-ref (build-edge-variables current-edge) "IMPLIB" (lambda () (error "SHSYM rule does not have IMPLIB variable"))))
    (define input-path (car (build-edge-inputs current-edge)))

    (define input-edge (mapping-ref edges input-path (lambda () (mapping-ref edges (normalize-path input-path) (lambda () (error "SHSYM input path does not exist"))))))

    (define command
      #~,(string-append #$llvm-bintools "/bin/llvm-ifs --output-elf=\"$out\" \"$input\"\n"
           #$patchelf "/bin/patchelf --set-rpath \"$(" #$patchelf "/bin/patchelf --print-rpath \"$input\")\" \"$out\""))

    (define processed
     (cdar
      (store-path-for-ca-drv*
       (make-valid-store-path-string (string-append "SHSYM shim for " implib))
       "x86_64-linux"
       (list "/bin/sh" "-c" command)
       #~(("input" . #$(force (car input-edge))))
       '("out"))))
    (cons implib processed))

  (define (build-edge env edges current-edge)
   (if (build-edge-resolved current-edge)
    (let*
     ((out-drv (delay (derivation-for-edge env edges current-edge)))
      (is-shsym (string=? (build-edge-rule current-edge) "SHSYM"))
      (shsym-ifs (and is-shsym (delay (ifs-for-shsym env edges current-edge)))))
     (make-built-edge current-edge out-drv shsym-ifs '()))
    (make-built-edge current-edge (delay (phony-edge edges current-edge)) #f (build-edge-inputs current-edge))))

  (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 (eq? (car input-file) 'phony)
       (for-each process-input (built-edge-phony-inputs (force (cdr input-file))))
       (set! copies (cons #~,(string-append "mkdir -p \"$out/$(dirname " path ")\"; cp -rf " #$(force (car 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"
      '("/bin/sh" "-c" "exec /bin/sh $ZILCH_CMDPath")
      #~(("ZILCH_CMD" . #$command) ("passAsFile" . "ZILCH_CMD") ("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 (cons 'base #f))))
     (vfs-contents (ninja-build-config-root-dir conf)))

    (define vfs-store-path (vfs-to-store (ninja-build-config-root-dir conf)))
    (define env (make-build-env conf vfs-store-path relative-to))
    (for-each
     (lambda (edge)
      (define built-edge (delay (build-edge env 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 (cons (delay #~,(string-append #$(force (built-edge-out-drv (force built-edge))) "/" v)) built-edge))))
          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 built-edge))))
          all-outputs)))
     (build-file-build-edges file))

    (define edge-ref
     (lambda (path)
       (define edge (mapping-ref/default edges path #f))
       (cons (if (promise? (car edge)) (force (car edge)) (car edge)) (force (cdr edge)))))
    (define defaults (build-file-default-targets file))
    (values edge-ref defaults))))