fae660b0e4
This was developed in a different repository, so the history will be archived there: https://github.com/jeapostrophe/galaxy
135 lines
4.9 KiB
Racket
135 lines
4.9 KiB
Racket
#lang racket/base
|
|
(require rackunit
|
|
racket/port
|
|
racket/system
|
|
unstable/debug
|
|
racket/match
|
|
(for-syntax racket/base
|
|
syntax/parse))
|
|
|
|
;; {{ Shelly
|
|
;; This macro is intended to make Eli proud.
|
|
|
|
;; Wow, RackUnit really sucks that test-begin/case don't work inside
|
|
;; each other like this already
|
|
(define (wrapping-test-case-around thunk)
|
|
(with-handlers ([exn:test:check?
|
|
(λ (e)
|
|
(raise (struct-copy
|
|
exn:test:check e
|
|
[stack (list* (make-check-name (current-test-name))
|
|
(exn:test:check-stack e))])))])
|
|
(thunk)))
|
|
(define-syntax-rule (check-begin e ...)
|
|
(parameterize ([current-test-case-around wrapping-test-case-around])
|
|
(test-begin e ...)))
|
|
(define-syntax-rule (check-case m e ...)
|
|
(parameterize ([current-test-case-around wrapping-test-case-around])
|
|
(test-case m e ...)))
|
|
|
|
(define-syntax-rule (check-similar? act exp name)
|
|
(let ()
|
|
(define exp-v exp)
|
|
(define act-v act)
|
|
(if (regexp? exp-v)
|
|
(check-regexp-match exp-v act-v name)
|
|
(check-equal? act-v exp-v name))))
|
|
|
|
(define (exn:input-port-closed? x)
|
|
(and (exn:fail? x)
|
|
(regexp-match #rx"input port is closed" (exn-message x))))
|
|
|
|
(begin-for-syntax
|
|
(define-splicing-syntax-class shelly-case
|
|
#:attributes (code)
|
|
(pattern (~seq (~datum $) command-line:expr
|
|
(~optional (~seq (~datum =exit>) exit-cond:expr)
|
|
#:defaults ([exit-cond #'0]))
|
|
(~optional (~seq (~datum =stdout>) output-str:expr)
|
|
#:defaults ([output-str #'#f]))
|
|
(~optional (~seq (~datum =stderr>) error-str:expr)
|
|
#:defaults ([error-str #'#f]))
|
|
(~optional (~seq (~datum <input=) input-str:expr)
|
|
#:defaults ([input-str #'#f])))
|
|
#:attr
|
|
code
|
|
(quasisyntax/loc
|
|
#'command-line
|
|
(let ([cmd command-line])
|
|
(check-case
|
|
cmd
|
|
(define output-port (open-output-string))
|
|
(define error-port (open-output-string))
|
|
(printf "$ ~a\n" cmd)
|
|
(match-define
|
|
(list stdout stdin pid stderr to-proc)
|
|
(process/ports #f
|
|
(and input-str
|
|
(open-input-string input-str))
|
|
#f
|
|
cmd))
|
|
(define stdout-t
|
|
(thread
|
|
(λ ()
|
|
(with-handlers ([exn:input-port-closed? void])
|
|
(copy-port stdout output-port
|
|
(current-output-port))))))
|
|
(define stderr-t
|
|
(thread
|
|
(λ ()
|
|
(with-handlers ([exn:input-port-closed? void])
|
|
(copy-port stderr error-port
|
|
(current-error-port))))))
|
|
(to-proc 'wait)
|
|
(define cmd-status (to-proc 'exit-code))
|
|
(when stdout (close-input-port stdout))
|
|
(when stderr (close-input-port stderr))
|
|
(when stdin (close-output-port stdin))
|
|
(thread-wait stdout-t)
|
|
(thread-wait stderr-t)
|
|
(define actual-output
|
|
(get-output-string output-port))
|
|
(define actual-error
|
|
(get-output-string error-port))
|
|
#,(syntax/loc #'command-line
|
|
(when output-str
|
|
(check-similar? actual-output output-str "stdout")))
|
|
#,(syntax/loc #'command-line
|
|
(when error-str
|
|
(check-similar? actual-error error-str "stderr")))
|
|
#,(syntax/loc #'command-line
|
|
(check-equal? cmd-status exit-cond "exit code"))))))
|
|
(pattern (~and (~not (~datum $))
|
|
code:expr))))
|
|
|
|
(define-syntax (shelly-begin stx)
|
|
(syntax-parse
|
|
stx
|
|
[(_ case:shelly-case ...)
|
|
(syntax/loc stx (test-begin case.code ...))]))
|
|
(define-syntax (shelly-case stx)
|
|
(syntax-parse
|
|
stx
|
|
[(_ m:expr case:shelly-case ...)
|
|
(syntax/loc stx
|
|
(let ()
|
|
(define mv m)
|
|
(check-case mv
|
|
(printf "# Starting... ~a\n" mv)
|
|
case.code ...
|
|
(printf "# Ending... ~a\n" mv))))]))
|
|
(define-syntax (shelly-wind stx)
|
|
(syntax-parse
|
|
stx
|
|
[(_ e:expr ... ((~datum finally) after:expr ...))
|
|
(syntax/loc stx
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(shelly-begin e ...))
|
|
(λ ()
|
|
(shelly-begin after ...))))]))
|
|
;; }}
|
|
|
|
(provide (all-defined-out))
|