commit 8b762275c08c966fc74ca05127741e4927349c45
parent 109659c456ca011163ed2dc909a29e35b63a276d
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 1 Jun 2017 16:43:31 +0200
First draft to allow #'x and #,x for matching as syntax variable or executing syntax-e, respectively, in the % form.
Diffstat:
2 files changed, 115 insertions(+), 0 deletions(-)
diff --git a/percent2.rkt b/percent2.rkt
@@ -0,0 +1,106 @@
+#lang typed/racket
+(require "typed-untyped.rkt")
+(define-typed/untyped-modules #:no-test
+ (provide % define% in let1)
+
+ (require (for-syntax syntax/parse
+ "typed-untyped.rkt")
+ "in.rkt")
+ (begin-for-syntax
+ (if-typed (require phc-toolkit/aliases)
+ (require phc-toolkit/untyped/aliases)))
+
+ (define-syntax-rule (let1 var val . body)
+ (let-values ([(var) val]) . body))
+
+ #|(define-syntax (% stx)
+ (syntax-parse stx #:literals (= → :)
+ [(_ (~seq (~or ((~and var (~not :)) ...)
+ (~seq (~and var (~not (~or = → :))) ...)) = expr)
+ ...
+ (~optional (~literal →)) . body)
+ #'(let-values ([(var ...) expr] ...) . body)]))|#
+
+ (define-for-syntax mymatch
+ (syntax-parser
+ #:literals (cons list vector syntax)
+ ;; TODO: use define/with-syntax if we are in syntax mode.
+ [(_ val (v:id)) #'(define v val)]
+ [(_ val (cons a b)) #'(begin (mymatch (car val) a)
+ (mymatch (car val) b))]
+ [(_ val null)
+ #'(assert val null?)]
+ ;; TODO: handle ellipses
+ [(_ val (list pat ...))
+ #'(mymatch val (list* pat ... null))]
+ [(_ val (list* pat ... rest-pat))
+ #:with (tmp* ...) (generate-temporaries #'(list pat ...))
+ #:with (tmp ... _) #'(tmp* ...)
+ #:with (_ new-tmp ...) #'(tmp* ...)
+ #:with (first . _) #'(tmp* ...)
+ #:with (_ ... last) #'(tmp* ...)
+ #'(begin
+ (define first val)
+ (begin (mymatch (car tmp) pat)
+ (define new-tmp (cdr tmp)))
+ ...
+ (mymatch last rest-pat))]))
+
+ (begin-for-syntax
+ (define-syntax-class %pat
+ (pattern v:id
+ #:with expanded #'v)
+ (pattern ()
+ #:with expanded #'(list))
+ (pattern ({~literal unsyntax} x:%pat)
+ #:with expanded #'(app syntax-e x.expanded))
+ (pattern (x:%pat . rest:%pat)
+ #:with expanded #'(cons x.expanded rest.expanded))
+ (pattern #(x:%pat …)
+ #:with expanded #'(vector x.expanded …)))
+ (define-splicing-syntax-class %assignment
+ #:attributes ([pat.expanded 1] [expr 0])
+ #:literals (= in)
+ (pattern (~seq (~and maybe-pat (~not (~or = in))) ...
+ (~datum =) expr:expr)
+ #:with [pat:%pat ...] #'(maybe-pat ...))))
+
+ (define-syntax (% stx)
+ (syntax-parse stx #:literals (= in)
+ [(_ :%assignment ... (~optional (~literal in)) . body)
+ #'(match-let*-values ([(pat.expanded ...) expr] ...)
+ . body)]))
+
+ (begin-for-syntax
+ (define-syntax-class typed-pat
+ (pattern [x:%pat (~literal :) type:expr]
+ #:with (tmp) (generate-temporaries #'(x))
+ #:with var-type #`[tmp : type]
+ #:with (expanded ...) #'([x.expanded tmp]))
+ (pattern x:id
+ #:with var-type #'x
+ #:with (expanded ...) #'())
+ (pattern x:%pat
+ #:with (tmp) (generate-temporaries #'(x))
+ #:with var-type #'tmp
+ #:with (expanded ...) #'([x.expanded tmp]))))
+
+ (define-syntax (define% stx)
+ (syntax-parse stx
+ [(_ (name param:typed-pat ...)
+ (~and (~seq ret ...) (~optional (~seq (~literal :) ret-type)))
+ . body)
+ #'(define (name param.var-type ...)
+ (match-let (param.expanded ... ...) ret ... . body))]))
+
+ #|
+ (begin-for-syntax
+ (define-syntax-class λ%expr
+ (pattern e:id #:where (symbol->string e))
+ (pattern e)
+ (pattern (e . rest:λ%expr))))
+
+ (define-syntax (λ% stx)
+ (syntax-parse stx
+ [(_ expr )]))
+ |#)
+\ No newline at end of file
diff --git a/test/test-percent2.rkt b/test/test-percent2.rkt
@@ -0,0 +1,7 @@
+#lang typed/racket
+(require phc-toolkit/percent2
+ typed/rackunit)
+(check-equal? (% #,x = #'y
+ in
+ x)
+ 'y)
+\ No newline at end of file
