diff options
| -rw-r--r-- | tools/magrathea/mg.scm | 106 |
1 files changed, 105 insertions, 1 deletions
diff --git a/tools/magrathea/mg.scm b/tools/magrathea/mg.scm index 90798f1567..c9a44f85d1 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) |