percent2.rkt (3686B)
1 #lang typed/racket 2 (require "typed-untyped.rkt") 3 (define-typed/untyped-modules #:no-test 4 (provide % define% in let1) 5 6 (require (for-syntax syntax/parse 7 "typed-untyped.rkt") 8 "in.rkt") 9 (begin-for-syntax 10 (if-typed (require phc-toolkit/aliases) 11 (require phc-toolkit/untyped/aliases))) 12 13 (define-syntax-rule (let1 var val . body) 14 (let-values ([(var) val]) . body)) 15 16 #|(define-syntax (% stx) 17 (syntax-parse stx #:literals (= → :) 18 [(_ (~seq (~or ((~and var (~not :)) ...) 19 (~seq (~and var (~not (~or = → :))) ...)) = expr) 20 ... 21 (~optional (~literal →)) . body) 22 #'(let-values ([(var ...) expr] ...) . body)]))|# 23 24 (define-for-syntax mymatch 25 (syntax-parser 26 #:literals (cons list vector syntax) 27 ;; TODO: use define/with-syntax if we are in syntax mode. 28 [(_ val (v:id)) #'(define v val)] 29 [(_ val (cons a b)) #'(begin (mymatch (car val) a) 30 (mymatch (car val) b))] 31 [(_ val null) 32 #'(assert val null?)] 33 ;; TODO: handle ellipses 34 [(_ val (list pat ...)) 35 #'(mymatch val (list* pat ... null))] 36 [(_ val (list* pat ... rest-pat)) 37 #:with (tmp* ...) (generate-temporaries #'(list pat ...)) 38 #:with (tmp ... _) #'(tmp* ...) 39 #:with (_ new-tmp ...) #'(tmp* ...) 40 #:with (first . _) #'(tmp* ...) 41 #:with (_ ... last) #'(tmp* ...) 42 #'(begin 43 (define first val) 44 (begin (mymatch (car tmp) pat) 45 (define new-tmp (cdr tmp))) 46 ... 47 (mymatch last rest-pat))])) 48 49 (begin-for-syntax 50 (define-syntax-class %pat 51 (pattern v:id 52 #:with expanded #'v) 53 (pattern () 54 #:with expanded #'(list)) 55 (pattern ({~literal unsyntax} x:%pat) 56 #:with expanded #'(app syntax-e x.expanded)) 57 (pattern (x:%pat . rest:%pat) 58 #:with expanded #'(cons x.expanded rest.expanded)) 59 (pattern #(x:%pat …) 60 #:with expanded #'(vector x.expanded …))) 61 (define-splicing-syntax-class %assignment 62 #:attributes ([pat.expanded 1] [expr 0]) 63 #:literals (= in) 64 (pattern (~seq (~and maybe-pat (~not (~or = in))) ... 65 (~datum =) expr:expr) 66 #:with [pat:%pat ...] #'(maybe-pat ...)))) 67 68 (define-syntax (% stx) 69 (syntax-parse stx #:literals (= in) 70 [(_ :%assignment ... (~optional (~literal in)) . body) 71 #'(match-let*-values ([(pat.expanded ...) expr] ...) 72 . body)])) 73 74 (begin-for-syntax 75 (define-syntax-class typed-pat 76 (pattern [x:%pat (~literal :) type:expr] 77 #:with (tmp) (generate-temporaries #'(x)) 78 #:with var-type #`[tmp : type] 79 #:with (expanded ...) #'([x.expanded tmp])) 80 (pattern x:id 81 #:with var-type #'x 82 #:with (expanded ...) #'()) 83 (pattern x:%pat 84 #:with (tmp) (generate-temporaries #'(x)) 85 #:with var-type #'tmp 86 #:with (expanded ...) #'([x.expanded tmp])))) 87 88 (define-syntax (define% stx) 89 (syntax-parse stx 90 [(_ (name param:typed-pat ...) 91 (~and (~seq ret ...) (~optional (~seq (~literal :) ret-type))) 92 . body) 93 #'(define (name param.var-type ...) 94 (match-let (param.expanded ... ...) ret ... . body))])) 95 96 #| 97 (begin-for-syntax 98 (define-syntax-class λ%expr 99 (pattern e:id #:where (symbol->string e)) 100 (pattern e) 101 (pattern (e . rest:λ%expr)))) 102 103 (define-syntax (λ% stx) 104 (syntax-parse stx 105 [(_ expr )])) 106 |#)