about summary refs log tree commit diff
path: root/tools/magrathea/mg.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tools/magrathea/mg.scm')
-rw-r--r--tools/magrathea/mg.scm316
1 files changed, 316 insertions, 0 deletions
diff --git a/tools/magrathea/mg.scm b/tools/magrathea/mg.scm
new file mode 100644
index 000000000000..a453da2ccd28
--- /dev/null
+++ b/tools/magrathea/mg.scm
@@ -0,0 +1,316 @@
+;; magrathea helps you build planets
+;;
+;; it is a tiny tool designed to ease workflows in monorepos that are
+;; modeled after the tvl depot.
+;;
+;; users familiar with workflows from other, larger monorepos may be
+;; used to having a build tool that can work in any tree location.
+;; magrathea enables this, but with nix-y monorepos.
+
+(import (chicken base)
+        (chicken format)
+        (chicken irregex)
+        (chicken port)
+        (chicken file)
+        (chicken file posix)
+        (chicken process)
+        (chicken process-context)
+        (chicken string)
+        (matchable)
+        (only (chicken io) read-string))
+
+(define usage #<<USAGE
+usage: mg <command> [<target>]
+
+target:
+  a target specification with meaning inside of the repository. can
+  be absolute (starting with //) or relative to the current directory
+  (as long as said directory is inside of the repo). if no target is
+  specified, the current directory's physical target is built.
+
+  for example:
+
+    //tools/magrathea - absolute physical target
+    //foo/bar:baz     - absolute virtual target
+    magrathea         - relative physical target
+    :baz              - relative virtual target
+
+commands:
+  build - build a target
+  shell - enter a shell with the target's build dependencies
+  path  - print source folder for the target
+  run   - build a target and execute its output
+
+file all feedback on b.tvl.fyi
+USAGE
+)
+
+;; parse target definitions. trailing slashes on physical targets are
+;; allowed for shell autocompletion.
+;;
+;; component ::= any string without "/" or ":"
+;;
+;; physical-target ::= <component>
+;;                   | <component> "/"
+;;                   | <component> "/" <physical-target>
+;;
+;; virtual-target ::= ":" <component>
+;;
+;; relative-target ::= <physical-target>
+;;                   | <virtual-target>
+;;                   | <physical-target> <virtual-target>
+;;
+;; root-anchor ::= "//"
+;;
+;; target ::= <relative-target> | <root-anchor> <relative-target>
+
+;; read a path component until it looks like something else is coming
+(define (read-component first port)
+  (let ((keep-reading?
+         (lambda () (not (or (eq? #\/ (peek-char port))
+                             (eq? #\: (peek-char port))
+                             (eof-object? (peek-char port)))))))
+    (let reader ((acc (list first))
+                 (condition (keep-reading?)))
+      (if condition (reader (cons (read-char port) acc) (keep-reading?))
+          (list->string (reverse acc))))))
+
+;; read something that started with a slash. what will it be?
+(define (read-slash port)
+  (if (eq? #\/ (peek-char port))
+      (begin (read-char port)
+             'root-anchor)
+      'path-separator))
+
+;; read any target token and leave port sitting at the next one
+(define (read-token port)
+  (match (read-char port)
+         [#\/ (read-slash port)]
+         [#\: 'virtual-separator]
+         [other (read-component other port)]))
+
+;; read a target into a list of target tokens
+(define (read-target target-str)
+  (call-with-input-string
+   target-str
+   (lambda (port)
+     (let reader ((acc '()))
+       (if (eof-object? (peek-char port))
+           (reverse acc)
+           (reader (cons (read-token port) acc)))))))
+
+(define-record target absolute components virtual)
+(define (empty-target) (make-target #f '() #f))
+
+(define-record-printer (target t out)
+  (fprintf out (conc (if (target-absolute t) "//" "")
+                     (string-intersperse (target-components t) "/")
+                     (if (target-virtual t) ":" "")
+                     (or (target-virtual t) ""))))
+
+;; parse and validate a list of target tokens
+(define parse-tokens
+  (lambda (tokens #!optional (mode 'root) (acc (empty-target)))
+    (match (cons mode tokens)
+           ;; absolute target
+           [('root . ('root-anchor . rest))
+            (begin (target-absolute-set! acc #t)
+                   (parse-tokens rest 'root acc))]
+
+           ;; relative target minus potential garbage
+           [('root . (not ('path-separator . _)))
+            (parse-tokens tokens 'normal acc)]
+
+           ;; virtual target
+           [('normal . ('virtual-separator . rest))
+            (parse-tokens rest 'virtual acc)]
+
+           [('virtual . ((? string? v)))
+            (begin
+              (target-virtual-set! acc v)
+              acc)]
+
+           ;; chomp through all components and separators
+           [('normal . ('path-separator . rest)) (parse-tokens rest 'normal acc)]
+           [('normal . ((? string? component) . rest))
+            (begin (target-components-set!
+                    acc (append (target-components acc) (list component)))
+                   (parse-tokens rest 'normal acc ))]
+
+           ;; nothing more to parse and not in a weird state, all done, yay!
+           [('normal . ()) acc]
+
+           ;; oh no, we ran out of input too early :(
+           [(_ . ()) `(error . ,(format "unexpected end of input while parsing ~s target" mode))]
+
+           ;; something else was invalid :(
+           [_ `(error . ,(format "unexpected ~s while parsing ~s target" (car tokens) mode))])))
+
+(define (parse-target target)
+  (parse-tokens (read-target target)))
+
+;; turn relative targets into absolute targets based on the current
+;; directory
+(define (normalise-target t)
+  (when (not (target-absolute t))
+    (target-components-set! t (append (relative-repo-path)
+                                      (target-components t)))
+    (target-absolute-set! t #t))
+  t)
+
+;; nix doesn't care about the distinction between physical and virtual
+;; targets, normalise it away
+(define (normalised-components t)
+  (if (target-virtual t)
+      (append (target-components t) (list (target-virtual t)))
+      (target-components t)))
+
+;; return the current repository root as a string
+(define mg--repository-root #f)
+(define (repository-root)
+  (or mg--repository-root
+      (begin
+        (set! mg--repository-root
+              (or (get-environment-variable "MG_ROOT")
+                  (string-chomp
+                   (call-with-input-pipe "git rev-parse --show-toplevel"
+                                         (lambda (p) (read-string #f p))))))
+        mg--repository-root)))
+
+;; determine the current path relative to the root of the repository
+;; and return it as a list of path components.
+(define (relative-repo-path)
+  (string-split
+   (substring (current-directory) (string-length (repository-root))) "/"))
+
+;; escape a string for interpolation in nix code
+(define (nix-escape str)
+  (string-translate* str '(("\"" . "\\\"")
+                           ("${" . "\\${"))))
+
+;; create a nix expression to build the attribute at the specified
+;; components
+;;
+;; an empty target will build the current folder instead.
+;;
+;; this uses builtins.getAttr explicitly to avoid problems with
+;; escaping.
+(define (nix-expr-for target)
+  (let nest ((parts (normalised-components (normalise-target target)))
+             (acc (conc "(import " (repository-root) " {})")))
+    (match parts
+           [() (conc "with builtins; " acc)]
+           [_ (nest (cdr parts)
+                    (conc "(getAttr \""
+                          (nix-escape (car parts))
+                          "\" " acc ")"))])))
+
+;; exit and complain at the user if something went wrong
+(define (mg-error message)
+  (format (current-error-port) "[mg] error: ~A~%" message)
+  (exit 1))
+
+(define (guarantee-success value)
+  (match value
+         [('error . message) (mg-error message)]
+         [_ value]))
+
+(define (execute-build t)
+  (let ((expr (nix-expr-for t)))
+    (fprintf (current-error-port) "[mg] building target ~A~%" t)
+    (process-execute "nix-build" (list "-E" expr "--show-trace"))))
+
+(define (build args)
+  (match args
+         ;; simplest case: plain mg build with no target spec -> build
+         ;; the current folder's main target.
+         [() (execute-build (empty-target))]
+
+         ;; single argument should be a target spec
+         [(arg) (execute-build
+                 (guarantee-success (parse-target arg)))]
+
+         [other (print "not yet implemented")]))
+
+(define (execute-shell t)
+  (let ((expr (nix-expr-for t))
+        (user-shell (or (get-environment-variable "SHELL") "bash")))
+    (fprintf (current-error-port) "[mg] entering shell for ~A~%" t)
+    (process-execute "nix-shell"
+                     (list "-E" expr "--command" user-shell))))
+
+(define (shell args)
+  (match args
+         [() (execute-shell (empty-target))]
+         [(arg) (execute-shell
+                 (guarantee-success (parse-target arg)))]
+         [other (print "not yet implemented")]))
+
+(define (execute-run t #!optional cmd-args)
+  (fprintf (current-error-port) "[mg] building target ~A~%" t)
+  (let* ((expr (nix-expr-for t))
+         (out (call-with-input-pipe
+               (apply string-append
+                      ;; TODO(sterni): temporary gc root
+                      (intersperse `("nix-build" "-E" ,(qs expr) "--no-out-link")
+                                   " "))
+               (lambda (p)
+                 (string-chomp (let ((s (read-string #f p)))
+                                 (if (eq? s #!eof) "" s)))))))
+
+    ;; TODO(sterni): can we get the exit code of nix-build somehow?
+    (when (= (string-length out) 0)
+      (mg-error (string-append "Couldn't build target " (format "~A" t)))
+      (exit 1))
+
+    (fprintf (current-error-port) "[mg] running target ~A~%" t)
+    (process-execute
+     ;; If the output is a file, we assume it's an executable à la writeExecline,
+     ;; otherwise we look in the bin subdirectory and pick the only executable.
+     ;; Handling multiple executables is not possible at the moment, the choice
+     ;; could be made via a command line flag in the future.
+     (if (regular-file? out)
+         out
+         (let* ((dir-path (string-append out "/bin"))
+                (dir-contents (if (directory-exists? dir-path)
+                                  (directory dir-path #f)
+                                  '())))
+           (case (length dir-contents)
+             ((0) (mg-error "no executables in build output")
+                  (exit 1))
+             ((1) (string-append dir-path "/" (car dir-contents)))
+             (else (mg-error "more than one executable in build output")
+                   (exit 1)))))
+     cmd-args)))
+
+(define (run args)
+  (match args
+         [() (execute-run (empty-target))]
+         ;; TODO(sterni): flag for selecting binary name
+         [other (execute-run (guarantee-success (parse-target (car args)))
+                             (cdr args))]))
+
+(define (path args)
+  (match args
+         [(arg)
+          (print (apply string-append
+                        (intersperse
+                         (cons (repository-root)
+                               (target-components
+                                (normalise-target
+                                 (guarantee-success (parse-target arg)))))
+                         "/")))]
+         [() (mg-error "path command needs a target")]
+         [other (mg-error (format "unknown arguments: ~a" other))]))
+
+(define (main args)
+  (match args
+         [() (print usage)]
+         [("build" . _) (build (cdr args))]
+         [("shell" . _) (shell (cdr args))]
+         [("path" . _) (path (cdr args))]
+         [("run" . _) (run (cdr args))]
+         [other (begin (print "unknown command: mg " args)
+                       (print usage))]))
+
+(main (command-line-arguments))