feat(tools/magrathea): add weirdly overengineered target spec parser r/3287

i'm not sure what happened here, but it works (yes, the fancy target
printing is completely unnecessary, but oh well):

    #;152> (parse-target "foo")
    #target(foo)

    #;153> (parse-target "//foo")
    #target(//foo)

    #;154> (parse-target "//foo/bar")
    #target(//foo/bar)

    #;155> (parse-target "//foo/bar/")
    #target(//foo/bar)

    #;156> (parse-target "//foo/bar:baz")
    #target(//foo/bar:baz)

    #;157> (parse-target "//foo/bar/:baz")
    #target(//foo/bar:baz)

    #;158> (parse-target "//foo/bar:")
    (error . "unexpected end of input while parsing virtual target")

    #;159> (parse-target "//foo//")
    (error . "unexpected root-anchor while parsing normal target")

the most notable thing is that trailing slashes are allowed in the
physical targets, since people may be autocompleting these on the
shell from folder names.

Change-Id: I32975ad77fe2a327130dc9574011fe92cce49f84
Reviewed-on: https://cl.tvl.fyi/c/depot/+/4393
Tested-by: BuildkiteCI
Reviewed-by: grfn <grfn@gws.fyi>
Reviewed-by: wpcarro <wpcarro@gmail.com>

1 files changed, 105 insertions, 1 deletions

diff --git a/tools/magrathea/mg.scm b/tools/magrathea/mg.scm
index 90798f156728..c9a44f85d117 100644
--- a/tools/magrathea/mg.scm
+++ b/tools/magrathea/mg.scm
@@ -8,8 +8,9 @@
 ;; magrathea enables this, but with nix-y monorepos.
 
 (import (chicken base)
-        (chicken io)
+        (chicken format)
         (chicken irregex)
+        (chicken port)
         (chicken process)
         (chicken process-context)
         (chicken string)
@@ -39,6 +40,109 @@ 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-record-printer (target t out)
+  (fprintf out (conc "#target("
+                     (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 (make-target #f '() #f)))
+    (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)))
+
 ;; return the current repository root as a string
 (define mg--repository-root #f)
 (define (repository-root)