expanders.rkt (1770B)
1 #lang racket 2 3 (require "expander-types.rkt" 4 syntax/parse 5 syntax/stx 6 predicates 7 fancy-app 8 racket/syntax) 9 10 (provide (struct-out expander) 11 (contract-out 12 [expander-of-type? (-> expander-type? expander? boolean?)] 13 [expand-syntax-tree-with-expanders-of-type (-> expander-type? syntax? syntax?)])) 14 15 (struct expander (type transformer)) 16 17 (define (expander-of-type? type expander) 18 (expander-type-includes? type (expander-type expander))) 19 20 (define (expander-stx? v) 21 (and (syntax? v) 22 (syntax-parse v 23 [(id:id . _) (syntax-local-value/record #'id expander?)] 24 [_ #f]))) 25 26 (define (expander-stx->expander expander-stx) 27 (syntax-parse expander-stx 28 [(id:id . _) (syntax-local-value/record #'id expander?)])) 29 30 (define (expander-stx-of-type? type v) 31 (and (expander-stx? v) 32 (expander-of-type? type (expander-stx->expander v)))) 33 34 (define (expand-syntax-tree fully-expanded-node? expand-syntax-once stx) 35 (if (fully-expanded-node? stx) 36 (syntax-parse stx 37 [(a ...) (datum->syntax stx (stx-map (expand-syntax-tree fully-expanded-node? expand-syntax-once _) #'(a ...)))] 38 [a #'a]) 39 (expand-syntax-tree fully-expanded-node? expand-syntax-once (expand-syntax-once stx)))) 40 41 (define (call-expander-transformer expander-stx) 42 (define expander (expander-stx->expander expander-stx)) 43 (define transformer (expander-transformer expander)) 44 (transformer expander-stx)) 45 46 (define (expand-syntax-tree-with-expanders-of-type type stx) 47 (define not-expander-stx-of-type? (not? (expander-stx-of-type? type _))) 48 (with-disappeared-uses 49 (expand-syntax-tree not-expander-stx-of-type? 50 call-expander-transformer 51 stx)))