ovl.rkt (2633B)
1 #lang at-exp racket/base 2 3 (provide ovl 4 ovl* 5 orig) 6 7 (require scribble/manual 8 (for-syntax racket/base 9 racket/function 10 racket/struct 11 racket/vector 12 racket/syntax 13 syntax/stx 14 syntax/strip-context)) 15 16 (begin 17 ;; From the type-expander docs: 18 (define-for-syntax (strip-loc e) 19 (cond [(syntax? e) (datum->syntax e (strip-loc (syntax-e e)) #f)] 20 [(pair? e) (cons (strip-loc (car e)) (strip-loc (cdr e)))] 21 [(vector? e) (vector-map strip-loc e)] 22 [(box? e) (box (strip-loc (unbox e)))] 23 [(prefab-struct-key e) 24 => (λ (k) (apply make-prefab-struct 25 k 26 (strip-loc (struct->list e))))] 27 [else e])) 28 29 (define-syntax (orig stx) 30 (syntax-case stx () 31 [(_ mod name ...) 32 (with-syntax ([(prefixed ...) 33 (stx-map (λ (id) (format-id id "orig:~a" id)) 34 #'(name ...))] 35 [(orig-module) (generate-temporaries #'(mod))]) 36 #`(begin 37 (module #,(datum->syntax #'mod (syntax-e #'orig-module)) . 38 #,(strip-context 39 #'(racket/base 40 (require (for-label (only-meta-in 0 (only-in mod 41 name ...)))) 42 (require scribble/manual) 43 (define prefixed @racket[name]) ... 44 (provide prefixed ...)))) 45 (require #,(datum->syntax #'mod `',(syntax-e #'orig-module)))))])) 46 47 (define-syntax (ovl* stx) 48 (syntax-case stx () 49 [(_ mod name ...) 50 (with-syntax ([(prefixed ...) 51 (stx-map (λ (id) (format-id #'mod "orig:~a" id)) 52 #'(name ...))] 53 [(stripped-name ...) 54 (stx-map strip-loc 55 #'(name ...))]) 56 #'(list 57 @defidform[stripped-name]{ 58 Overloaded version of @|prefixed| from 59 @racketmodname[mod].} 60 ...))])) 61 62 (define-syntax (ovl stx) 63 (syntax-case stx () 64 [(self mod name ...) 65 (identifier? #'mod) 66 #'(self #:wrapper list mod name ...)] 67 [(self #:wrapper wrapper mod name ...) 68 (identifier? #'mod) 69 #'(self #:wrapper wrapper #:require mod mod name ...)] 70 [(_ #:wrapper wrapper #:require req mod name ...) 71 #'(begin 72 (orig req name ...) 73 (wrapper (ovl* mod name ...)))])))