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

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

    ; 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 " #$vfs-store-path " bdir\n"
          #$coreutils "/bin/chmod ugo+rw -R bdir\n"
          "(COREUTILS=" #$coreutils "/bin; " #$copy-input-files ")\n"
          "cd 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)))
    (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 vfs))
    (define vfs-store-path (vfs-to-store vfs))
    (for-each
     (lambda (edge)
      (define processed (delay (derivation-for-edge environment vfs-store-path relative-to edges edge)))
      (if (build-edge-resolved 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)))

        ; This edge is phony; mark the edge as having its outputs.
        (for-each (lambda (v) (set! edges (mapping-set! edges v (cons 'phony (build-edge-inputs edge)))))
          (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))))