syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

pattern-expander.rkt

This commit is contained in:
Tony Garnock-Jones 2018-05-04 17:52:16 +01:00
parent d053edc101
commit daba892a07
3 changed files with 68 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
syndicate/pattern-expander.rkt Normal file
View File

@ -0,0 +1,23 @@
#lang racket/base
(require auxiliary-macro-context)
(define-auxiliary-macro-context
#:context-name pattern-expander
#:prop-name prop:pattern-expander
#:prop-predicate-name pattern-expander?
#:prop-accessor-name pattern-expander-proc
#:macro-definer-name define-pattern-expander
#:introducer-parameter-name current-pattern-expander-introducer
#:local-introduce-name syntax-local-pattern-expander-introduce
#:expander-id-predicate-name pattern-expander-id?
#:expander-transform-name pattern-expander-transform)
(provide (for-syntax
prop:pattern-expander
pattern-expander?
pattern-expander-proc
syntax-local-pattern-expander-introduce
pattern-expander-id?
pattern-expander-transform)
define-pattern-expander)

35
syndicate/pattern.rkt
View File

@ -11,12 +11,15 @@
desc->skeleton-stx
desc->capture-proj
desc->capture-names
desc->assertion-stx))
desc->assertion-stx)
(all-from-out "pattern-expander.rkt"))
(require (for-syntax racket/base))
(require (for-syntax racket/match))
(require (for-syntax racket/struct-info))
(require (for-syntax syntax/stx))
(require "pattern-expander.rkt")
(struct discard () #:prefab)
(struct capture (detail) #:prefab)
@ -35,6 +38,9 @@
;; The other `SkProj` generates a second `SkKey` which is used as the
;; input to a handler function.
(define-for-syntax orig-insp
(variable-reference->module-declaration-inspector (#%variable-reference)))
(begin-for-syntax
(define (dollar-id? stx)
(and (identifier? stx)
@ -61,7 +67,14 @@
(free-identifier=? #'vector stx)))
(define (analyse-pattern stx)
(syntax-case stx ($ quasiquote unquote quote)
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case disarmed-stx ($ quasiquote unquote quote)
[(expander args ...)
(pattern-expander-id? #'expander)
(pattern-expander-transform disarmed-stx
(lambda (result)
(analyse-pattern (syntax-rearm result stx))))]
;; Extremely limited support for quasiquoting and quoting
[(quasiquote (unquote p)) (analyse-pattern #'p)]
[(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
@ -95,7 +108,14 @@
(list 'atom stx)]))
(define (instantiate-pattern->pattern stx)
(syntax-case stx ($ quasiquote unquote quote)
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case disarmed-stx ($ quasiquote unquote quote)
[(expander args ...)
(pattern-expander-id? #'expander)
(pattern-expander-transform disarmed-stx
(lambda (result)
(instantiate-pattern->pattern (syntax-rearm result stx))))]
;; Extremely limited support for quasiquoting and quoting
[(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
[(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
@ -123,7 +143,14 @@
#'other]))
(define (instantiate-pattern->value stx)
(syntax-case stx ($ quasiquote unquote quote)
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case disarmed-stx ($ quasiquote unquote quote)
[(expander args ...)
(pattern-expander-id? #'expander)
(pattern-expander-transform disarmed-stx
(lambda (result)
(instantiate-pattern->value (syntax-rearm result stx))))]
;; Extremely limited support for quasiquoting and quoting
[(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
[(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]

14
syndicate/test/pattern-test.rkt
View File

@ -51,4 +51,18 @@
(foo (bar 'beep) $cap)
(s->d desc->assertion-stx))
(define-pattern-expander foo123
(syntax-rules ()
[(_ zot) (foo 123 zot)]))
(define-pattern-expander foo234
(syntax-rules ()
[(_ zot) (foo 234 zot)])
(syntax-rules ()
[(_ zot) (foo 234 zot)]))
(check-analyse-pattern '(foo 123 'zot) (foo123 'zot))
(check-analyse-pattern '(foo 234 'zot) (foo234 'zot))
(check-equal? (foo 234 'zot) (foo234 'zot))
)