zilch/cli/zilch-ninja.scm

(import (scheme base) (scheme write) (zilch statusbar) (zilch nix daemon) (zilch magic) (zilch lib getopt) (scheme process-context) (chicken process-context) (srfi 146) (chicken port) (chicken foreign) (chicken condition))
(foreign-declare "#include <sched.h>")

(define get-cpu-count
  (foreign-lambda* int ()
    "cpu_set_t set; sched_getaffinity(0, sizeof(set), &set); C_return(CPU_COUNT(&set));"))

(foreign-declare "#include \"man_ninja.h\"")
(define man-page (foreign-value "man_ninja" nonnull-c-string))

(define (print-help msg)
  (when msg
    (write-string (string-append msg "\n\n") (current-error-port)))
  (write-string man-page (current-error-port))
  (exit (or (not msg) 1)))

(define-values (options args)
 (getopt
  '((help #f #\h)
    (config-file #t #\f)
    (max-jobs #t #\j)
    (verbose #f #\v)
    (source #t #\s)
    (print-build-logs #f #\L))
  (list->vector (cdr (command-line)))
  print-help))

(when (assoc 'help options) (print-help #f))

(when (null? args)
  (print-help "No subcommand"))

;; Flags passed to the nix daemon:
(define max-jobs (if (assoc 'max-jobs options) (string->number (cdr (assoc 'max-jobs options))) (get-cpu-count)))
(define verbosity 3)
(for-each (lambda (val) (when (eq? (car val) 'verbose) (set! verbosity (+ 1 verbosity)))) options)
(write-string (string-append "Connected to Nix daemon, version " (daemon-link-daemon-version (*daemon*)) "\n") (current-error-port))

(daemon-wop-set-options (*daemon*) verbosity max-jobs #t)
(ca-thread-count max-jobs)

(import
  (scheme base) (scheme file) (scheme read)
  (chicken format) (chicken process) (chicken file)
  (zilch lang ninja) (zilch lang ninja build)
  (zilch lang ninja nixpkgs)
  (zilch lang ninja config)
  (zilch magic) (zilch nixpkgs) (zilch vfs)
  (zilch nix drv)
  (zilch zexpr)
  (srfi 128) (srfi 146) (srfi 152))

(define source (and (assoc 'source options) (cdr (assoc 'source options))))

(define config-path (if (assoc 'config-file options) (cdr (assoc 'config-file options)) "zilch.scm"))
(define config (parse-ninja-config `(override-source: ,source ,@(call-with-input-file config-path read))))

(when (and (ninja-build-config-depfile-path config) (file-exists? (ninja-build-config-depfile-path config)))
  (set-ninja-build-config-depfile! config (alist->mapping (make-default-comparator) (call-with-input-file (ninja-build-config-depfile-path config) read))))

(define (export-depfiles finalized-drv)
 (define config (finalized-drv-config finalized-drv))
 (when (ninja-build-config-depfile-path config)
  (call-with-output-file (ninja-build-config-depfile-path config) (lambda (p) (write (mapping->alist (finalized-drv-depfile finalized-drv)) p))))
 (for-each (lambda (v) (export-depfiles (force (drv-rewrite-finalized-drv v)))) (finalized-drv-rewritten-drvs finalized-drv)))

(cond
 ((string=? (car args) "source")
  (let*-values
   (((_ configured-drv _ _ _ _ _) (setup-ninja-environment config '()))
    ((realised) (store-path-realised configured-drv))
    ((path) (if (null? (cdr args)) "src" (cadr args))))
   (system* (string-append "cp -rf --no-preserve=ownership " realised "/src " (qs path)))
   (system* (string-append "chmod -R u+rw " (qs path)))))
 ((string=? (car args) "build")
  (if (null? (cdr args))
   (let ((output (build-nixpkgs-drv-reproducibly config)))
    (for-each
     (lambda (output-and-path)
      (store-path-realised (cdr output-and-path))
      (printf "~A\t-> ~S\n" (car output-and-path) (cdr output-and-path)))
     (finalized-drv-output-store-paths output))
    (export-depfiles output))
   (let-values (((_ _ _ edge-ref defaults _) (setup-ninja-environment config)))
    (for-each
     (lambda (target)
      (define built-target (edge-ref target))
      (printf "~A\t-> ~S\n" target (store-path-realised (force (built-edge-out-drv (cdr built-target))))))
     (cdr args)))))
 ((string=? (car args) "diff")
  (let*-values
   (((_ configured-drv _ _ _ _ _) (setup-ninja-environment config '()))
    ((realised) (store-path-realised configured-drv))
    ((path) (or source "src")))
   (process-execute "git" (list "diff" "--no-index" "--" (string-append realised "/src") path))))
 (else
  (print-help (string-append "Unknown subcommand " (car args)))))