Initial commit

cli/zilch-go.scm

@@ -0,0 +1,106 @@
+(import (scheme base) (scheme write) (zilch statusbar) (zilch nix daemon) (zilch lib getopt) (scheme process-context) (chicken process-context) (srfi 146) (chicken port))
+(define (print-help msg)
+  (when msg
+    (write-string (string-append msg "\n\n") (current-error-port)))
+  (write-string "Usage: zilch-cli-go [OPTION] [PACKAGE...]
+Process the given module (or the current directory, if unspecified) and
+output derivations for each package given on the command line (or all
+executables in the module, if unspecified)
+
+  -h, --help              Print this help message.
+  -b, --build             Build the store paths, rather than show their
+                          derivations.
+  -L, --print-build-logs  Print derivation logs as they come in.
+  -m, --module-dir DIR    The directory to use as root module.
+  -r, --replace DIR       Replace the module specified by the go.mod
+                          with this source directory, rather than using
+                          the upstream module. Can be specified more
+                          than once.
+
+   --debug                Crash on the first error, rather than
+                          continuing with the next package.
+" (current-error-port))
+  (exit (or (not msg) 1)))
+
+(define-values (options args)
+ (getopt
+  '((help #f #\h)
+    (module-dir #t #\m)
+    (print-build-logs #f #\L)
+    (build #f #\b)
+    (replace #t #\r)
+    (debug #f))
+  (list->vector (cdr (command-line)))
+  print-help))
+(when (assoc 'help options) (print-help #f))
+
+(define module-dir (if (assoc 'module-dir options) (cdr (assoc 'module-dir options)) (current-directory)))
+
+(define (set-print-logs val) #f)
+
+(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)))
+
+(define do-build (assoc 'build options))
+(define do-debug (assoc 'debug options))
+
+(import
+  (scheme file) (chicken file) (chicken format)
+  (zilch magic)
+  (zilch lang go mod) (zilch lang go vfs) (zilch lang go)
+  (zilch nix drv)
+  (zilch lang go))
+
+(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"))
+          (store-path-materialize linked)
+          (if do-build
+            (begin
+              (store-path-build linked)
+              (write-string (store-path-realisation linked)))
+            (write-string (derivation-path (store-path-drv 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))