ids.rkt (12464B)
1 #lang typed/racket 2 (require "typed-untyped.rkt") 3 (define-typed/untyped-modules #:no-test #:untyped-first 4 (provide !temp 5 (rename-out [!temp &]) 6 format-ids 7 hyphen-ids 8 format-temp-ids 9 #|!temp|# 10 define-temp-ids) 11 12 (require "typed-untyped.rkt" 13 "untyped-only/syntax-parse.rkt") 14 (require-typed/untyped "sequence.rkt") 15 (if-typed (require phc-toolkit/aliases) 16 (require phc-toolkit/untyped/aliases)) 17 (begin-for-syntax (require "typed-untyped.rkt" 18 "untyped-only/format-id-record.rkt") 19 (if-typed (require phc-toolkit/aliases) 20 (require phc-toolkit/untyped/aliases))) 21 22 (module m-!temp racket 23 (provide !temp) 24 25 (require syntax/parse 26 syntax/parse/experimental/template) 27 28 (define-template-metafunction (!temp stx) 29 (syntax-parse stx 30 [(_ id:id) 31 #:with (temp) (generate-temporaries #'(id)) 32 #'temp] 33 #|[(_ . id:id) 34 #:with (temp) (generate-temporaries #'(id)) 35 #'temp] 36 [(_ id:id ...) 37 (generate-temporaries #'(id ...))]|#))) 38 (require 'm-!temp) 39 40 (require/typed racket/syntax 41 [format-id (→ Syntax String (U String Identifier) * 42 Identifier)]) 43 (require (only-in racket/syntax define/with-syntax) 44 (only-in syntax/stx stx-map) 45 (for-syntax racket/base 46 racket/format 47 racket/syntax 48 syntax/parse 49 syntax/parse/experimental/template)) 50 ;(require racket/sequence) ;; in-syntax 51 52 (define-type S-Id-List 53 (U String 54 Identifier 55 (Listof String) 56 (Listof Identifier) 57 (Syntaxof (Listof Identifier)))) 58 59 ; TODO: format-ids doesn't accept arbitrary values. Should we change it? 60 ; 61 (: format-ids (→ (U Syntax (→ (U String Identifier) * Syntax)) 62 String 63 S-Id-List * 64 (Listof Identifier))) 65 (define (format-ids lex-ctx format . vs) 66 (let* ([seqs 67 (map (λ ([v : S-Id-List]) 68 (cond 69 [(string? v) (in-cycle (in-value v))] 70 [(identifier? v) (in-cycle (in-value v))] 71 [(list? v) (in-list v)] 72 [else (in-list (syntax->list v))])) 73 vs)] 74 [justconstants (andmap (λ (x) (or (string? x) (identifier? x))) vs)] 75 [seqlst (apply sequence-list seqs)]) 76 (for/list : (Listof Identifier) 77 ([items seqlst] 78 [bound-length (if justconstants 79 (in-value 'yes) 80 (in-cycle (in-value 'no)))]) 81 82 (apply format-id 83 (if (procedure? lex-ctx) (apply lex-ctx items) lex-ctx) 84 format 85 items)))) 86 87 (: hyphen-ids (→ (U Syntax (→ (U String Identifier) * Syntax)) 88 S-Id-List * 89 (Listof Identifier))) 90 91 (define (hyphen-ids lex-ctx . vs) 92 (apply format-ids 93 lex-ctx 94 (string-join (map (λ _ "~a") vs) "-") 95 vs)) 96 97 (: format-temp-ids (→ String 98 S-Id-List * 99 (Listof Identifier))) 100 101 (define (format-temp-ids format . vs) 102 ;; Introduce the binding in a fresh scope. 103 (apply format-ids 104 (λ _ ((make-syntax-introducer) (if (syntax? format) 105 format 106 (datum->syntax #f '())))) 107 format 108 vs)) 109 110 (: to-identifier (→ Any Identifier)) 111 (define (to-identifier v) 112 (cond 113 [(identifier? v) v] 114 [(syntax? v) (datum->syntax v (to-symbol (syntax-e v)))] 115 [else (datum->syntax #f (to-symbol v))])) 116 117 (: to-symbol (→ Any Symbol)) 118 (define (to-symbol v) 119 (cond 120 [(symbol? v) v] 121 [(string? v) (string->symbol v)] 122 [(number? v) (string->symbol (format "~a" v))] 123 [else (syntax-e (generate-temporary v))])) 124 125 (: generate-string (→ String)) 126 (define (generate-string) 127 (symbol->string 128 (syntax-e 129 (generate-temporary "")))) 130 131 (require (for-syntax (submod "stx.rkt" untyped))) 132 133 134 (: curried-map-on-attribute-step 135 (∀ (A B) (→ (→ A B) 136 (case→ (→ #f #f) 137 (→ (Listof A) (Listof B)) 138 (→ (U #f (Listof A)) 139 (U #f (Listof B))))))) 140 (define ((curried-map-on-attribute-step f) l) 141 (if (eq? l #f) 142 l 143 (map f l))) 144 145 (: curried-map-on-attribute-last 146 (∀ (A B) (→ (→ (Syntaxof A) B) 147 (case→ (→ #f #f) 148 (→ (Syntaxof A) B) 149 (→ (U #f (Syntaxof A)) (U #f B)))))) 150 (define ((curried-map-on-attribute-last f) v) 151 (if (eq? v #f) 152 v 153 (f v))) 154 155 ;; (map-on-attribute f depth) 156 (define-syntax (map-on-attribute stx) 157 (syntax-case stx () 158 [(_ f 0) 159 #'(curried-map-on-attribute-last f)] 160 [(_ f depth) 161 #`(curried-map-on-attribute-step 162 (map-on-attribute f 163 #,(sub1 (syntax-e #'depth))))])) 164 165 (begin-for-syntax 166 (define-syntax-class dotted 167 (pattern id:id 168 #:attr make-dotted 169 (λ (x) x) 170 #:attr wrap 171 (λ (x f) (f x #t)) 172 #:attr depth 0 173 #:with stx-depth #'0) 174 (pattern (nested:dotted (~literal ...));(~and dots (~literal ...)) ...+) 175 #:with id #'nested.id 176 #:attr make-dotted 177 (λ (x) #`(#,((attribute nested.make-dotted) x) (... ...))) 178 #:attr wrap 179 (λ (x f) (f ((attribute nested.wrap) x f) #f)) 180 #:attr depth (add1 (attribute nested.depth)) 181 #:with stx-depth #`#,(add1 (attribute nested.depth)))) 182 183 (define-syntax-class simple-format 184 (pattern format 185 #:when (string? (syntax-e #'format)) 186 #:when (regexp-match #rx"^([^~]|~~)*~a([^~]|~~)*$" 187 (syntax-e #'format))))) 188 189 ;; This macro should really be heavily refactored. 190 ;; TODO: merge all cases thanks to format-id/record and syntax classes. 191 (define-syntax (define-temp-ids stx) 192 (with-arrows 193 (syntax-parse stx 194 #| 195 ;; TODO : factor this with the next case. 196 [(_ format ((base:id (~literal ...)) (~literal ...))) 197 #:when (string? (syntax-e #'format)) 198 (with-syntax ([pat (format-id #'format (syntax-e #'format) #'base)]) 199 #'(define/with-syntax ((pat (... ...)) (... ...)) 200 (stx-map (curry format-temp-ids format) 201 #'((base (... ...)) (... ...)))))] 202 |# 203 204 ;; Multiple formats 205 [(_ {~and {~optional #:concise} {~seq maybe-concise …}} 206 (format:simple-format …) 207 (~and (~seq options …) 208 (~seq base:dotted 209 (~or (~seq #:first-base first-base) 210 (~optional (~seq #:first first))) 211 (~optional (~seq #:prefix prefix))))) 212 #'(begin (define-temp-ids maybe-concise … format options …) …)] 213 214 ;; New features (arrows and #:first) special-cased for now 215 ;; TODO: make these features more general. 216 217 ;; With #:first-base, translated to #:first 218 [(_ {~and {~optional #:concise} {~seq maybe-concise …}} 219 format:simple-format base:dotted 220 #:first-base first-base 221 (~optional (~seq #:prefix prefix))) 222 #:with first (format-id/record #'format #'format #'first-base) 223 (template 224 (define-temp-ids maybe-concise … format base 225 #:first first 226 (?? (?@ #:prefix prefix))))] 227 228 ;; Base case with a simple format "...~a...". 229 [(_ {~optional {~and #:concise concise?}} 230 format:simple-format 231 base:dotted 232 (~optional (~seq #:first first)) 233 (~optional (~seq #:first… first…)) 234 (~optional (~seq #:prefix prefix))) 235 (let* ([base-len (string-length (symbol->string (syntax-e #'base.id)))]) 236 (define/with-syntax pat 237 (format-id/record #'format #'format #'base.id)) 238 (define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat)) 239 240 (define/with-syntax maybe-generate-temporary 241 (if (attribute concise?) 242 #'to-identifier 243 #'generate-temporary)) 244 (define/with-syntax format-temp-ids-last 245 (template 246 (λ (x) 247 (car (format-temp-ids (?? (?@ (string-append "~a:" format) prefix) 248 format) 249 (maybe-generate-temporary x)))))) 250 (define/with-syntax format-temp-ids* 251 #'(map-on-attribute format-temp-ids-last base.stx-depth)) 252 (define/with-syntax (tmp-valvar) (generate-temporaries #`(base.id))) 253 (define/with-syntax do-define-pat 254 (syntax-parse (attribute-info #'base.id '(pvar attr)) 255 [({~datum attr} valvar depth name syntax?) 256 #'(define-raw-attribute pat 257 tmp-valvar 258 (format-temp-ids* valvar) 259 depth 260 syntax?)] 261 [({~datum pvar} valvar depth) 262 #'(define-raw-syntax-mapping pat 263 tmp-valvar 264 (format-temp-ids* valvar) 265 depth)])) 266 (define/with-syntax do-define-first… 267 (if (attribute first…) 268 (let () 269 (define/with-syntax (tmp-first-valvar) 270 (generate-temporaries #`(base.id))) 271 (syntax-parse (attribute-info #'base.id '(pvar attr)) 272 [({~datum attr} valvar depth name syntax?) 273 ;; TODO: always define an attribute, but don't use 274 ;; define-raw-attribute, instead use the copy-attribute 275 ;; code from subtemplate. 276 #`(define-raw-attribute first… 277 tmp-first-valvar 278 (car tmp-valvar) 279 #,(sub1 (syntax-e #'depth)) 280 syntax?)] 281 [({~datum pvar} valvar depth) 282 #`(define-raw-syntax-mapping first… 283 tmp-first-valvar 284 (car tmp-valvar) 285 #,(sub1 (syntax-e #'depth)))])) 286 #'(begin))) 287 (define/with-syntax do-define-first 288 (if (attribute first) 289 #'(define/with-syntax (first . _) 290 #'pat-dotted) 291 #'(begin))) 292 #'(begin do-define-pat 293 do-define-first 294 do-define-first…))] 295 296 ;; Simplistic handling when the format contains no ~ at all. 297 ;; (TODO: should allow ~~) 298 [(_ {~optional {~and #:concise concise?}} format base:dotted) 299 #:when (string? (syntax-e #'format)) 300 #:when (regexp-match #rx"^([^~]|~~)*$" (syntax-e #'format)) 301 (define/with-syntax pat (format-id/record #'format #'format)) 302 (define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat)) 303 (define/with-syntax format-temp-ids* 304 ((attribute base.wrap) #`(λ (x) 305 #,(if (attribute concise?) 306 #'(car (format-temp-ids 307 (string-append format))) 308 #'(car (format-temp-ids 309 (string-append format "-~a") 310 (generate-string))))) 311 (λ (x deepest?) 312 (if deepest? 313 x 314 #`(curry stx-map #,x))))) 315 #'(define/with-syntax pat-dotted 316 (format-temp-ids* #'base))] 317 318 ;; Very simplistic handling when the name is explicitly given. 319 [(_ {~optional {~and #:concise concise?}} 320 name:id format:expr . vs) 321 #`(define/with-syntax name (format-temp-ids format . vs))]))))