implementation.rkt (9174B)
1 #lang racket 2 (provide #%dotted-id 3 #%dot-separator 4 make-#%module-begin 5 make-#%top-interaction) 6 7 (require typed/racket) 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 (make-#%module-begin stx) 41 (syntax-case stx () 42 ;; -mrt = -make-rename-transformer 43 [(_ name wrapped-#%module-begin -λ -define-syntax -mrt -app1 -syntax) 44 #'(define-syntax (name stx2) 45 (syntax-case stx2 () 46 [(_ . body) 47 (datum->syntax 48 stx2 49 `(,#'wrapped-#%module-begin 50 . ,(fold-syntax (replace-dots #'-λ 51 #'-define-syntax 52 #'-mrt 53 #'-app1 54 #'-syntax) 55 #'body)) 56 stx2 57 stx2)]))])) 58 59 (define-syntax (make-#%top-interaction stx) 60 (syntax-case stx () 61 ;; -mrt = -make-rename-transformer 62 [(_ name wrapped-#%top-interaction -λ -define-syntax -mrt -app1 -syntax) 63 #'(define-syntax (name stx2) 64 (syntax-case stx2 () 65 [(_ . body) 66 (datum->syntax 67 stx2 68 `(,#'wrapped-#%top-interaction 69 . ,(fold-syntax (replace-dots #'-λ 70 #'-define-syntax 71 #'-mrt 72 #'-app1 73 #'-syntax) 74 #'body)) 75 stx2 76 stx2)]))])) 77 78 (define-for-syntax (make-λ l args e percent? 79 -λ -define-syntax -mrt -app1 -syntax) 80 (define percent* 81 (if (and percent? (>= (length args) 1)) 82 `{(,-define-syntax % (,-app1 ,-mrt (,-syntax ,(car args))))} 83 '{})) 84 ;`(letrec ([%0 (,#'λ ,args ,@percent* ,e)]) %0) 85 (datum->syntax l `(,-λ ,args ,@percent* ,e) l l)) 86 87 (define-for-syntax (make-args l str* pos) 88 (if (empty? str*) 89 '() 90 (let () 91 (define str (car str*)) 92 (define len (string-length str)) 93 (cons (datum->syntax l 94 (string->symbol str) 95 (update-source-location l 96 #:position pos 97 #:span len) 98 l) 99 (make-args l (cdr str*) (+ pos 1 len)))))) 100 101 (define-for-syntax (find-% stx) 102 (define found 0) 103 (define (found! n) (set! found (max found n))) 104 (fold-syntax (λ (e recurse) 105 (if (and (identifier? e) 106 (regexp-match #px"^%[1-9][0-9]*$" 107 (identifier→string e))) 108 (found! (string->number 109 (cadr (regexp-match #px"^%([1-9][0-9]*)$" 110 (identifier→string e))))) 111 (if (and (identifier? e) 112 (string=? (identifier→string e) "%")) 113 (found! 1) 114 (recurse e)))) 115 stx) 116 found) 117 118 (begin-for-syntax 119 (define-splicing-syntax-class (elt -λ -define-syntax -mrt -app1 -syntax) 120 (pattern {~seq {~and l {~datum λ.}} e:expr} 121 #:with expanded 122 (let ([args (for/list ([arg (in-range 1 (add1 (find-% #'e)))]) 123 (datum->syntax #'l 124 (string->symbol (format "%~a" arg)) 125 #'l 126 #'l))]) 127 (make-λ #'l args #'e #t -λ -define-syntax -mrt -app1 -syntax))) 128 (pattern {~seq l:id e:expr} 129 #:when (regexp-match #px"^λ([^.]+\\.)+$" (identifier→string #'l)) 130 #:with expanded 131 (let* ([m (regexp-match* #px"[^.]+" (identifier→string #'l) 1)] 132 [args (make-args #'l 133 m 134 (+ (syntax-position #'l) 1))]) 135 (make-λ #'l args #'e #f -λ -define-syntax -mrt -app1 -syntax))) 136 (pattern e 137 #:with expanded #'e))) 138 139 (define-for-syntax ((replace-dots -λ -define-syntax -mrt -app1 -syntax) 140 stx recurse) 141 (syntax-parse stx 142 ;; Fast path: no dots or ellipses. 143 [x:id #:when (regexp-match #px"^[^.…]*$" (identifier→string #'x)) 144 #'x] 145 ;; Protected identifiers, which are not altered. 146 [x:id #:when (regexp-match #px"^(\\.*|…|\\.\\.\\.?[+*]|…[+*]|::\\.\\.\\.)$" 147 (identifier→string #'x)) 148 #'x] 149 ;; A trailing dot is dropped and escapes the preceding identifier. 150 [x:id #:when (regexp-match #px"\\.$" (identifier→string #'x)) 151 (let* ([str (identifier→string #'x)] 152 [unescaped (substring str 0 (sub1 (string-length str)))]) 153 (datum->syntax stx (string->symbol unescaped) stx stx))] 154 [x:id #:when (regexp-match #px"[.…]" 155 (identifier→string #'x)) 156 (let* ([str (symbol->string (syntax-e #'x))] 157 [leading-dot? (regexp-match #px"^\\." str)] 158 [components* (regexp-match* #px"([^.…]|\\.\\.+)+|…" 159 str 160 #:gap-select? #t)] 161 [components (if leading-dot? 162 (drop-right components* 1) 163 (cdr (drop-right components* 1)))] 164 [unescaped (map (λ (m) 165 (regexp-replace* #px"\\.(\\.+)" m "\\1")) 166 components)] 167 [identifiers ((to-ids stx) components 168 unescaped 169 0 170 leading-dot?)] 171 [trailing-dot? (regexp-match #px"\\.$" str)]) 172 (define/with-syntax (id …) identifiers) 173 (if (= (length identifiers) 1) 174 (quasisyntax/loc stx 175 #,(car identifiers)) 176 (quasisyntax/loc stx 177 (#,(datum->syntax #'here '#%dotted-id stx stx) id …))))] 178 [{~and whole ({~var || (elt -λ -define-syntax -mrt -app1 -syntax)} … 179 . {~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*)))