/utils.rkt

 1#lang racket/base
 2
 3(require scheme/match scheme/system scheme/promise
 4         (for-syntax scheme/base syntax/boundmap))
 5
 6(provide from-env run-command call-with-PATH defmatcher domatchers defautoloads)
 7
 8;; this is used when this module is loaded, before `clearenv' is called
 9(define (from-env var default [split #f])
10  (let ([val (getenv var)])
11    (if (and val (> (string-length val) 0))
12      (if split (regexp-split split val) val)
13      default)))
14
15;; Capture the initial path for all kinds of things that need it
16(define default-path (getenv "PATH"))
17(define (call-with-PATH thunk)
18  (dynamic-wind
19    (lambda () (putenv "PATH" default-path))
20    thunk
21    (lambda () (putenv "PATH" "")))) ; no way to actually delete a var
22
23;; Conveniently running an external process (given its name and string args)
24;; and return the stdout in a string
25(define (run-command cmd . args)
26  (define exe (call-with-PATH (lambda () (find-executable-path cmd))))
27  (define out (open-output-string))
28  (parameterize ([current-output-port out])
29    (if (and exe (apply system* exe args))
30      (get-output-string out)
31      "unknown")))
32
33;; Allows defining matchers separately, easier to maintain code.
34(define-for-syntax matcher-patterns (make-free-identifier-mapping))
35(define-syntax (defmatcher stx)
36  (syntax-case stx ()
37    [(_ name pattern body ...)
38     (begin (free-identifier-mapping-put!
39             matcher-patterns #'name
40             (cons #'[pattern body ...]
41                   (free-identifier-mapping-get matcher-patterns #'name
42                                                (lambda () '()))))
43            #'(begin))]))
44(define-syntax (domatchers stx)
45  (syntax-case stx ()
46    [(_ name val)
47     #`(match val #,@(reverse (free-identifier-mapping-get matcher-patterns
48                                                           #'name)))]))
49
50;; used to delay loading libraries
51(define-syntax defautoloads
52  (syntax-rules ()
53    [(_ [lib var])
54     (begin (define hidden (delay (dynamic-require 'lib 'var)))
55            (define-syntax var
56              (syntax-id-rules (set!)
57                [(set! . _) (error 'var "cannot mutate")]
58                [(x . xs) ((force hidden) . xs)]
59                [_ (force hidden)])))]
60    [(_ [lib var ...])
61     (begin (defautoloads (lib var)) ...)]
62    [(_ [lib var ...] ...)
63     (begin (defautoloads (lib var ...)) ...)]))