;; Parses the Zilch-specific Ninja configuration.
(define-library (zilch lang ninja config)
 (import
  (scheme base) (scheme eval)
  (zilch magic) (zilch nixpkgs) (zilch vfs)
  (srfi 88) (srfi 152)
  (prefix (only scheme eval) scheme-))

 (export
  <ninja-build-config> ninja-build-config?
  ninja-build-config-environment ninja-build-config-environment-drv
  ninja-build-config-root-dir ninja-build-config-patches ninja-build-config-targets
  ninja-build-config-override-source ninja-build-config-override-source-path
  ninja-build-config-depfile ninja-build-config-depfile-path
  ninja-build-config-disallow-elide ninja-build-config-rewrites

  set-ninja-build-config-root-dir! set-ninja-build-config-environment! set-ninja-build-config-depfile!
  
  <drv-rewrite>
  make-drv-rewrite drv-rewrite?
  drv-rewrite-source-paths drv-rewrite-finalized-drv
  drv-rewrite-vfs-bases drv-rewrite-overlay-paths

  parse-ninja-config)

 (begin
   ;; Represents a parsed Ninja build configuration.
   ;; See `parse-ninja-config` for the definition of these fields.
   (define-record-type <ninja-build-config>
    (make-ninja-build-config environment environment-drv root-dir patches targets override-source override-source-path depfile depfile-path disallow-elide rewrites)
    ninja-build-config?
    (environment ninja-build-config-environment set-ninja-build-config-environment!)
    (environment-drv ninja-build-config-environment-drv set-ninja-build-config-environment-drv!)
    (root-dir ninja-build-config-root-dir set-ninja-build-config-root-dir!)
    (patches ninja-build-config-patches set-ninja-build-config-patches!)
    (targets ninja-build-config-targets set-ninja-build-config-targets!)
    (override-source ninja-build-config-override-source set-ninja-build-config-override-source!)
    (override-source-path ninja-build-config-override-source-path set-ninja-build-config-override-source-path!)
    (depfile ninja-build-config-depfile set-ninja-build-config-depfile!)
    (depfile-path ninja-build-config-depfile-path set-ninja-build-config-depfile-path!)
    (disallow-elide ninja-build-config-disallow-elide set-ninja-build-config-disallow-elide!)
    (rewrites ninja-build-config-rewrites set-ninja-build-config-rewrites!))

   (define (relative-to-file path path2)
    (if (string-prefix? "/" path2) path2
     (let ((last-slash (string-contains-right path "/")))
      (if last-slash
        (string-append (string-copy path 0 last-slash) "/" path2)
        path2))))

   (define (parse-config-inner path accept-override conf data)
    (cond
     ((null? data) conf)
     ((null? (cdr data)) (error "Expected even list of directives in Zilch Ninja config"))
     (else
      (case (car data)
       ((#:env #:environment)
        (if (string? (list-ref data 1))
         (let ((drv (cdar (nixpkgs-eval (list-ref data 1)))))
           (set-ninja-build-config-environment! conf (environment-for-derivation drv))
           (set-ninja-build-config-environment-drv! conf (store-path-drv drv)))
         (set-ninja-build-config-environment! conf (list-ref data 1)))
        (parse-config-inner path accept-override conf (cddr data)))
       ((#:root)
        (set-ninja-build-config-root-dir! conf (if (string? (list-ref data 1)) (vfs-from-directory (list-ref data 1)) (list-ref data 1)))
        (parse-config-inner path accept-override conf (cddr data)))
       ((#:override-source)
        (when (string? (list-ref data 1))
         (set-ninja-build-config-override-source-path! conf (relative-to-file path (list-ref data 1))))
        (when accept-override
         (set-ninja-build-config-override-source! conf (if (string? (list-ref data 1)) (vfs-from-directory (relative-to-file path (list-ref data 1))) (list-ref data 1))))
        (parse-config-inner path accept-override conf (cddr data)))
       ((#:depfile-path)
        (set-ninja-build-config-depfile-path! conf (relative-to-file path (list-ref data 1)))
        (parse-config-inner path accept-override conf (cddr data)))
       ((#:depfile)
        (set-ninja-build-config-depfile! conf (list-ref data 1))
        (parse-config-inner path accept-override conf (cddr data)))
       ((#:patch)
        (let*
         ((patch-base (list-ref data 1))
          (processed-patch
           (cond
            ((string? patch-base)
             (lambda (target) patch-base))
            ((list? patch-base)
             (scheme-eval patch-base))
            (else patch-base))))
         (set-ninja-build-config-patches! conf (cons processed-patch (ninja-build-config-patches conf))))
        (parse-config-inner path accept-override conf (cddr data)))
       ((#:disallow-elide)
        (let*
         ((thunk (list-ref data 1))
          (processed-thunk
           (cond
            ((list? thunk)
             (scheme-eval thunk))
            (else thunk))))
         (set-ninja-build-config-disallow-elide! conf processed-thunk)) 
        (parse-config-inner path accept-override conf (cddr data)))
       ((#:target #:targets)
        (when (eq? (ninja-build-config-targets conf) #f)
          (set-ninja-build-config-targets! conf '()))
        (let*
         ((val (list-ref data 1))
          (list-val (if (list? val) val (list val))))
         (set-ninja-build-config-targets! conf (append list-val (ninja-build-config-targets conf))))
        (parse-config-inner path accept-override conf (cddr data)))
       ((#:rewrite)
        (let*
         ((val (list-ref data 1)))
         (set-ninja-build-config-rewrites! conf (cons (cons (car val) (parse-ninja-config path accept-override (cdr val))) (ninja-build-config-rewrites conf))))
        (parse-config-inner path accept-override conf (cddr data)))
       (else (error (string-append "Unknown directive " (keyword->string (car data)) " parsing Zilch Ninja config")))))))
  
   ;; Parses a Zilch Ninja configuration file.
   ;;
   ;; A Zilch Ninja configuration file is a list containing repeated keys and values.
   ;;
   ;; - `env:`/`environment: ...`: The environment to be used when processing
   ;;   the Ninja file. If the environment is a string, it is assumed to be a
   ;;   Nix expression resolving to a derivation, and will be evaluated in the
   ;;   context of Nixpkgs. Otherwise, it is assumed to be a (optionally
   ;;   `zexp`) alist of environment variables.
   ;; - `root: dir`: The root directory that contains both the source and
   ;;   necessary Ninja build files. If string, assumed to be a directory
   ;;   relative to the working directory; assumed to be a `<vfs>` otherwise.
   ;; - `override-source: dir`: The source override directory. Only used by
   ;;   `build-nixpkgs-drv-reproducibly`, ignored otherwise.
   ;; - `depfile-path: path`: The location of a depfile cache to use, as a
   ;;   string relative to the current working directory. Only used by
   ;;   `zilch-cli-ninja`.
   ;; - `depfile: #<mapping>`: An SRFI146 mapping output file names to a list
   ;;   of input dependencies. Used to elide inputs where possible.
   ;; - `patch: proc`: A patch procedure (or a list which evaluates to one).
   ;;   A patch procedure takes a `<build-edge>, and outputs `#f` or a string
   ;;   of shell commands to run before evaluating the rule's command.
   ;; - `disallow-elide: proc`: A procedure that takes the path of a file and
   ;;   can return `#t` to reject its elision. Used to special-case files that
   ;;   would normally be elided, but shouldn't, in cases where the depfile is
   ;;   incorrect.
   ;; - `target: "foo"`/`targets: '("foo" "bar")`: Build these targets instead
   ;;   of the default specified in the Ninja file.
   ;; - `rewrite: ("<derivation name>" . <nested config>): A nested Zilch
   ;;   Ninja configuration to swap out the input derivation with equivalent
   ;;   name.
   ;;
   ;; `path` is the path this file was located at, used to resolve relative paths for depfiles.
   ;; `accept-override` specifies whether override-source arguments are processed.
   (define (parse-ninja-config path accept-override config)
    (unless (list? config)
     (error "expected Zilch Ninja config to be a list"))
    (parse-config-inner path accept-override (make-ninja-build-config #f #f #f '() #f #f #f #f #f #f '()) config))

   ;; `source-paths`: mapping of original store path to virtual path.
   ;; `finalized-drv`: promise of a <finalized-drv>
   ;; `vfs-bases`: mapping of virtualised path to base VFS
   ;; `overlay-paths`: alist of virtualised path to promise of a store path
   (define-record-type <drv-rewrite>
    (make-drv-rewrite source-paths finalized-drv vfs-bases overlay-paths)
    drv-rewrite?
    (source-paths drv-rewrite-source-paths)
    (finalized-drv drv-rewrite-finalized-drv)
    (vfs-bases drv-rewrite-vfs-bases)
    (overlay-paths drv-rewrite-overlay-paths))))