131 lines
3.5 KiB
Plaintext
Executable File
131 lines
3.5 KiB
Plaintext
Executable File
#! /usr/bin/scheme-script
|
|
|
|
(import (rnrs)
|
|
(fmt fmt)
|
|
(list-utils)
|
|
(functional-tests)
|
|
(cache-functional-tests)
|
|
(parser-combinators)
|
|
(only (srfi s1 lists) break)
|
|
(regex)
|
|
(srfi s8 receive)
|
|
(thin-functional-tests))
|
|
|
|
;;------------------------------------------------
|
|
|
|
;; Returns #t if the xs list matches prefix
|
|
(define (begins-with prefix xs)
|
|
(cond
|
|
((null? prefix) #t)
|
|
((null? xs) #f)
|
|
((eq? (car prefix) (car xs))
|
|
(begins-with (cdr prefix) (cdr xs)))
|
|
(else #f)))
|
|
|
|
(define (split-list xs sep)
|
|
(define (safe-cdr xs)
|
|
(if (null? xs) '() (cdr xs)))
|
|
|
|
(if (null? xs)
|
|
'()
|
|
(receive (p r) (break (lambda (c)
|
|
(eq? c sep))
|
|
xs)
|
|
(cons p (split-list (safe-cdr r) sep)))))
|
|
|
|
(define (string->syms str sep)
|
|
(map (lambda (cs)
|
|
(string->symbol
|
|
(list->string cs)))
|
|
(split-list (string->list str) sep)))
|
|
|
|
(define (mk-string-matcher pattern)
|
|
(let ((prefix (string->syms pattern #\/)))
|
|
(lambda (keys)
|
|
(begins-with prefix keys))))
|
|
|
|
(define (mk-regex-matcher pattern)
|
|
(let ((rx (regex pattern)))
|
|
(lambda (keys)
|
|
(rx (apply string-append
|
|
(intersperse "/"
|
|
(map symbol->string keys)))))))
|
|
|
|
;; If the filter begins with 're:' then we make a regex matcher, otherwise
|
|
;; we use a simple string matcher.
|
|
(define (mk-single-matcher pattern)
|
|
(if (string=? (substring pattern 0 3) "re:")
|
|
(mk-regex-matcher (substring pattern 3 (string-length pattern)))
|
|
(mk-string-matcher pattern)))
|
|
|
|
(define (mk-filter patterns)
|
|
(if (null? patterns)
|
|
; accept everything if no patterns
|
|
(lambda (_) #t)
|
|
|
|
; Otherwise accept tests that pass a pattern
|
|
(let ((filters (map mk-single-matcher patterns)))
|
|
(fold-left (lambda (fn-a fn-b)
|
|
(lambda (keys)
|
|
(or (fn-a keys)
|
|
(fn-b keys))))
|
|
(car filters)
|
|
(cdr filters)))))
|
|
|
|
(define (exec-help)
|
|
(fmt (current-error-port)
|
|
(dsp "here's some helpful help\n")))
|
|
|
|
(define (exec-run args)
|
|
(let ((pred (mk-filter args)))
|
|
(if (run-scenarios (filter pred (list-scenarios)))
|
|
(exit)
|
|
(exit #f))))
|
|
|
|
;;------------------------------------------------
|
|
;; Command line parser
|
|
|
|
(define (switch str)
|
|
(>> (lit "--") (lit str)))
|
|
|
|
(define whitespace
|
|
(many+ (charset " \t\n")))
|
|
|
|
(define (whitespace-delim ma)
|
|
(>> (opt whitespace)
|
|
(<* ma (opt whitespace))))
|
|
|
|
(define not-switch
|
|
(parse-m (<- c (neg-charset "- \t"))
|
|
(<- cs (many* (neg-charset " \t")))
|
|
(pure (list->string (cons c cs)))))
|
|
|
|
(define command-line-parser
|
|
(alt (>> (switch "help") (pure exec-help))
|
|
(parse-m (switch "run")
|
|
(<- args (many* (whitespace-delim not-switch)))
|
|
(pure (lambda ()
|
|
(exec-run args))))))
|
|
|
|
(define (bad-command-line)
|
|
(fmt (current-error-port) (dsp "bad command line\n")))
|
|
|
|
;; (<string>) -> thunk
|
|
(define (parse-command-line)
|
|
(let ((args (cdr (command-line))))
|
|
(receive (v st)
|
|
(parse command-line-parser
|
|
(apply string-append
|
|
(intersperse " "
|
|
(cdr (command-line)))))
|
|
(if (success? st)
|
|
v
|
|
bad-command-line))))
|
|
|
|
;;------------------------------------------------
|
|
|
|
(register-thin-tests)
|
|
(register-cache-tests)
|
|
((parse-command-line))
|
|
|