mode.rkt (1752B)
1 #lang racket/base 2 (provide (struct-out mode) 3 make-mode 4 current-mode 5 with-mode 6 make-param-mode) 7 8 9 ;; mode object. contains setup routine and teardown routine 10 ;; as fields. 11 (struct mode (setup-fn teardown-fn)) 12 13 (define (make-mode #:setup [setup-fn void] 14 #:teardown [teardown-fn void]) 15 (mode setup-fn teardown-fn)) 16 17 18 ;; apply the given mode for the successive expressions. 19 ;; e.g. 20 ;; (with-mode (mode (λ () (display "before ")) 21 ;; (λ () (display "after\n"))) 22 ;; (display "middle ")) 23 ;; -> 24 ;; before middle after 25 ;; 26 ;; (with-mode <mode> <body> ...) 27 (define-syntax-rule (with-mode mode-expr body ...) 28 (let* ([the-mode mode-expr]) 29 ((mode-setup-fn the-mode)) 30 (begin0 (parameterize ([current-mode the-mode]) body ...) 31 ((mode-teardown-fn the-mode))))) 32 33 34 ;; the current set mode. useful for #:submode/mode 35 (define current-mode 36 (make-parameter (mode void void))) 37 38 39 ;; returns a mode that sets the given 40 ;; parameter to the given value, for its duration. 41 ;; similar to (parameterize ([P value]) ...) 42 ;; 43 ;; make-param-mode : ∀T. (parameterof T) T -> mode? 44 (define (make-param-mode P value) 45 (let* ([swap! (λ () 46 (let ([cur (P)]) 47 (P value) 48 (set! value cur)))]) 49 (mode swap! swap!))) 50 51 52 53 (module+ test 54 (require rackunit) 55 56 (define color (make-parameter 'red)) 57 58 (define ->blue (make-param-mode color 'blue)) 59 (define ->green (make-param-mode color 'green)) 60 61 (with-mode ->blue 62 (check-equal? (color) 'blue)) 63 (check-equal? (color) 'red) 64 65 (with-mode ->green 66 (check-equal? (color) 'green) 67 (with-mode ->blue 68 (check-equal? (color) 'blue)) 69 (check-equal? (color) 'green)) 70 )