zilch/cli/zilch-go.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_go.h\"")
(define man-page (foreign-value "man_go" 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)
    (max-jobs #t #\j)
    (verbose #f #\v)
    (print-build-logs #f #\L)
    (module-dir #t #\m)
    (replace #t #\r)
    (debug #f))
  (list->vector (cdr (command-line)))
  print-help))

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

;; Set up the logger.
(define (set-print-logs val) #f)
(let ((prev-error-handler (current-exception-handler))) (current-exception-handler (lambda data (set-print-logs #t) (apply prev-error-handler data))))
(when (terminal-port? (current-error-port))
  (let-values (((new-out new-err statusbar-set-print-logs logger) (statusbar-logger (current-output-port) (current-error-port) (assoc 'print-build-logs options))))
    (current-output-port new-out)
    (current-error-port new-err)
    (set! set-print-logs statusbar-set-print-logs)
    (*logger* logger)))

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

;; Set the options, ensuring the Go toolchain is substituted where possible.
(daemon-wop-set-options (*daemon*) verbosity max-jobs #t)
(import (zilch lang go core))
(store-path-build go-toolchain)
(daemon-wop-set-options (*daemon*) verbosity max-jobs #f)


(import
  (scheme file) (chicken file) (chicken format)
  (zilch magic) (zilch vfs)
  (zilch lang go mod) (zilch lang go vfs) (zilch lang go)
  (zilch nix drv)
  (zilch lang go))

(define module-dir (if (assoc 'module-dir options) (cdr (assoc 'module-dir options)) (current-directory)))
(define do-debug (assoc 'debug options))

(unless (file-exists? (string-append module-dir "/go.mod"))
  (set-print-logs #t)
  (fprintf (current-error-port) "Refusing to use directory ~S as it contains no go.mod.\n" module-dir)
  (exit 1))
(define vfs (vfs-from-directory module-dir))
(define replaces '())
(for-each
  (lambda (kv)
    (when (eq? (car kv) 'replace)
      (unless (file-exists? (string-append (cdr kv) "/go.mod"))
        (set-print-logs #t)
        (fprintf (current-error-port) "Refusing to use directory ~S as it contains no go.mod.\n" (cdr kv))
        (exit 1))
      (set! replaces (cons (vfs-from-directory (cdr kv)) replaces))))
  options)

(define-values (module-name collected-requires) (collect-requirements-for-module vfs replaces))
(define-values (find-package find-packages-for-module) (collect-packages-from-requires collected-requires))

(define (print-package-info package-name skip-if-not-bin)
  (define-values (package err)
    (call-with-current-continuation
      (lambda (cc)
        (if do-debug
          (values (find-package package-name) #f)
          (with-exception-handler (lambda (err) (cc #f err)) (lambda () (values (find-package package-name) #f)))))))
  (if err
    (write-string (string-append package-name "\tskipped: " (error-object-message err) "\n"))
    (begin
      (if (string=? (go-package-name package) "main")
        (let ((linked (go-package-link package)))
          (write-string (string-append package-name "\t"))
          (write-string (store-path-realised linked))
          (newline))
        (unless skip-if-not-bin
          (write-string (string-append package-name "\tnot a binary\n")))))))

(if (eqv? args '())
   (for-each
     (lambda (package) (print-package-info package #t))
     (find-packages-for-module module-name))
   (for-each
     (lambda (package) (print-package-info package #f))
     args))