unhygienic-implementation.rkt (8995B)
1 #lang racket 2 (provide #%dotted-id 3 #%dot-separator 4 new-#%module-begin 5 make-#%top-interaction) 6 7 (require chain-module-begin) 8 (require (for-syntax debug-scopes)) 9 10 (require racket/stxparam 11 (for-syntax racket/string 12 racket/list 13 syntax/parse 14 racket/syntax 15 syntax/strip-context 16 racket/struct 17 racket/function 18 syntax/srcloc 19 "private/fold.rkt" 20 (only-in racket/base [... …]))) 21 22 (define-for-syntax identifier→string (compose symbol->string syntax-e)) 23 24 (define-syntax (#%dot-separator stx) 25 (raise-syntax-error '#%dot-separator 26 "Can only be used in special contexts" 27 stx)) 28 29 (define-syntax (~> stx) 30 (syntax-case stx () 31 [(_ v) #'v] 32 [(_ v f . f*) #'(~> (f v) . f*)])) 33 34 (define-syntax-parameter #%dotted-id 35 (syntax-parser 36 #:literals (#%dot-separator) 37 [(_ {~seq #%dot-separator e} …) #'(λ (v) (~> v e …))] 38 [(_ e₀ {~seq #%dot-separator e} …) #'(~> e₀ e …)])) 39 40 (define-syntax (new-#%module-begin stx) 41 (syntax-parse stx 42 [(_ {~or lang:id (lang:id . chain₊)} . body) 43 (datum->syntax 44 stx 45 `(,#'chain-module-begin ,#'lang ,@(if (attribute chain₊) `(,#'chain₊) '()) 46 . ,(fold-syntax replace-dots #'body)) 47 stx 48 stx)])) 49 50 (define-syntax (make-#%top-interaction stx) 51 (syntax-case stx () 52 [(_ name wrapped-#%top-interaction) 53 #'(define-syntax (name stx2) 54 (syntax-case stx2 () 55 [(_ . body) 56 (datum->syntax 57 stx2 58 `(,#'wrapped-#%top-interaction 59 . ,(fold-syntax replace-dots 60 #'body)) 61 stx2 62 stx2)]))])) 63 64 (define-for-syntax (make-λ l args e percent?) 65 (define percent* 66 (if (and percent? (>= (length args) 1)) 67 (datum->syntax l 68 `{(define-syntax ,(datum->syntax l '% (%-loc l)) 69 (#%plain-app make-rename-transformer #',(car args)))} 70 (build-source-location-list 71 (update-source-location l #:span 1))) 72 #'{})) 73 ;`(letrec ([%0 (,#'λ ,args ,@percent* ,e)]) %0) 74 (define -λ 75 (datum->syntax l 'λ 76 (build-source-location-list 77 (update-source-location l #:span 1)))) 78 (datum->syntax l #`(#,-λ #,args #,@percent* #,e) l l)) 79 80 (define-for-syntax (make-args l str* pos) 81 (if (empty? str*) 82 '() 83 (let () 84 (define str (car str*)) 85 (define len (string-length str)) 86 (cons (datum->syntax l 87 (string->symbol str) 88 (build-source-location-list 89 (update-source-location l 90 #:position pos 91 #:span len)) 92 l) 93 (make-args l (cdr str*) (+ pos 1 len)))))) 94 95 (define-for-syntax (find-% stx) 96 (define found 0) 97 (define (found! n) (set! found (max found n))) 98 (fold-syntax (λ (e recurse) 99 (if (and (identifier? e) 100 (regexp-match #px"^%[1-9][0-9]*$" 101 (identifier→string e))) 102 (found! (string->number 103 (cadr (regexp-match #px"^%([1-9][0-9]*)$" 104 (identifier→string e))))) 105 (if (and (identifier? e) 106 (string=? (identifier→string e) "%")) 107 (found! 1) 108 (recurse e)))) 109 stx) 110 found) 111 112 (begin-for-syntax 113 (define (%-loc l) 114 (build-source-location-list 115 (update-source-location l 116 #:position (let ([p (syntax-position l)]) 117 (and p (+ p 1))) 118 #:column (let ([c (syntax-column l)]) 119 (and c (+ c 1))) 120 #:span 1))) 121 (define-splicing-syntax-class elt 122 (pattern {~seq {~and l {~datum λ.}} e:expr} 123 #:with expanded 124 (let ([args (for/list ([arg (in-range 1 (add1 (find-% #'e)))]) 125 (datum->syntax #'l 126 (string->symbol (format "%~a" arg)) 127 (%-loc #'l) 128 #'l))]) 129 (make-λ #'l args #'e #t))) 130 (pattern {~seq l:id e:expr} 131 #:when (regexp-match #px"^λ([^.]+\\.)+$" (identifier→string #'l)) 132 #:with expanded 133 (let* ([m (regexp-match* #px"[^.]+" (identifier→string #'l) 1)] 134 [args (make-args #'l 135 m 136 (+ (syntax-position #'l) 1))]) 137 (make-λ #'l args #'e #f))) 138 (pattern e 139 #:with expanded #'e))) 140 141 (define-for-syntax (replace-dots stx recurse) 142 (syntax-parse stx 143 ;; Fast path: no dots or ellipses. 144 [x:id #:when (regexp-match #px"^[^.…]*$" (identifier→string #'x)) 145 #'x] 146 ;; Protected identifiers, which are not altered. 147 [x:id #:when (regexp-match #px"^(\\.*|…|\\.\\.\\.?[+*]|…[+*]|::\\.\\.\\.)$" 148 (identifier→string #'x)) 149 #'x] 150 ;; A trailing dot is dropped and escapes the preceding identifier. 151 [x:id #:when (regexp-match #px"\\.$" (identifier→string #'x)) 152 (let* ([str (identifier→string #'x)] 153 [unescaped (substring str 0 (sub1 (string-length str)))]) 154 (datum->syntax stx (string->symbol unescaped) stx stx))] 155 [x:id #:when (regexp-match #px"[.…]" 156 (identifier→string #'x)) 157 (let* ([str (symbol->string (syntax-e #'x))] 158 [leading-dot? (regexp-match #px"^\\." str)] 159 [components* (regexp-match* #px"([^.…]|\\.\\.+)+|…" 160 str 161 #:gap-select? #t)] 162 [components (if leading-dot? 163 (drop-right components* 1) 164 (cdr (drop-right components* 1)))] 165 [unescaped (map (λ (m) 166 (regexp-replace* #px"\\.(\\.+)" m "\\1")) 167 components)] 168 [identifiers ((to-ids stx) components 169 unescaped 170 0 171 leading-dot?)] 172 [trailing-dot? (regexp-match #px"\\.$" str)]) 173 (define/with-syntax (id …) identifiers) 174 (if (= (length identifiers) 1) 175 (quasisyntax/loc stx 176 #,(car identifiers)) 177 (quasisyntax/loc stx 178 (#,(datum->syntax #'here '#%dotted-id stx stx) id …))))] 179 [{~and whole (:elt … . {~and tail {~not (_ . _)}})} 180 ;; TODO: keep the stx-pairs vs stx-lists structure where possible. 181 (recurse (datum->syntax #'whole 182 (syntax-e #'(expanded … . tail)) 183 #'whole 184 #'whole))] 185 [_ (recurse stx)])) 186 187 (define-for-syntax (to-ids stx) 188 (define (process component* unescaped* len-before dot?) 189 (if (empty? component*) 190 '() 191 (let () 192 (define component (car component*)) 193 (define unescaped (car unescaped*)) 194 (define len (string-length component)) 195 (define len-after (+ len-before len)) 196 (define pos (+ (syntax-position stx) len-before)) 197 (define loc (update-source-location stx #:position pos #:span len)) 198 (define id 199 (datum->syntax stx 200 (if dot? 201 '#%dot-separator 202 (string->symbol unescaped)) 203 loc 204 stx)) 205 (define id-p 206 (if dot? (syntax-property id 'dotted-original-chars unescaped) id)) 207 (cons id-p 208 (process (cdr component*) 209 (cdr unescaped*) 210 len-after 211 (not dot?)))))) 212 process) 213 214 (define-for-syntax (map-fold f init . l*) 215 (car 216 (apply foldl 217 (λ all-args 218 (define vs+acc (last all-args)) 219 (define args (drop-right all-args 1)) 220 (define new-v+new-acc (apply f (append args (list (cdr vs+acc))))) 221 (cons (cons (car new-v+new-acc) 222 (car vs+acc)) 223 (cdr new-v+new-acc))) 224 (cons '() init) 225 l*)))