Skip to content

Commit

Permalink
define-extension
Browse files Browse the repository at this point in the history
  • Loading branch information
@michaelballantyne
michaelballantyne committed May 23, 2024
1 parent 06fc689 commit 31e0839
Show file tree
Hide file tree
Showing 4 changed files with 109 additions and 117 deletions.
20 changes: 17 additions & 3 deletions private/syntax/interface.rkt
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
#lang racket/base

(provide syntax-spec
define-extension
(for-syntax racket-expr
racket-var
racket-macro
Expand Down Expand Up @@ -296,9 +297,9 @@

(define (generate-body)
#`(with-syntax ([compiled-names (check-lhs-result
(syntax-parse #f
[_
#,@(add-scope #'[name-parse-body ...] sc)]))])
(syntax-parse #f
[_
#,@(add-scope #'[name-parse-body ...] sc)]))])
(trampoline-lift! #'(define-values compiled-names (pass2-macro . #,(compile-sspec-to-template sspec))))
#'(begin)))

Expand Down Expand Up @@ -346,6 +347,15 @@
e:expr
#:binding (host e)))



(define-syntax define-extension
(syntax-parser
[(_ name eclass rhs)
(define space (eval-transformer #'(extension-class-space eclass)))
(define/syntax-parse name/space ((in-space space) #'name))
#'(define-syntax name/space (eclass rhs))]))

;;
;; phase 1 accessors
;;
Expand Down Expand Up @@ -377,4 +387,8 @@

(define-syntax binding-class-predicate
(accessor-macro bindclass-rep? "expected a binding class name" bindclass-rep-pred))

(define-syntax extension-class-space
(accessor-macro extclass-rep? "expected an extension class name"
(lambda (b) #`'#,(extclass-rep-binding-space b))))
)
12 changes: 5 additions & 7 deletions tests/dsls/match.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,10 +25,10 @@
[p:pat body:racket-expr ...+]
#:binding (scope (import p) body))
(host-interface/expression
(match target:racket-expr c:clause ...)
#'(with-reference-compilers ([pat-var immutable-reference-compiler])
(let ([target-pv target])
(match-clauses target-pv c ...)))))
(match target:racket-expr c:clause ...)
#'(with-reference-compilers ([pat-var immutable-reference-compiler])
(let ([target-pv target])
(match-clauses target-pv c ...)))))

(define-syntax match-clauses
(syntax-parser
Expand Down Expand Up @@ -58,12 +58,10 @@
[(not p)
#'(do-match target p on-fail on-success)])]))

; TODO shouldn't have to mess with make-interned-syntax-introducer
(define-syntax define-match-expander
(syntax-parser
[(_ name:id trans:expr)
#`(define-syntax #,((make-interned-syntax-introducer 'pm) #'name 'add)
(pat-macro trans))]))
#`(define-extension name pat-macro trans)]))

(define-match-expander _
(syntax-parser
Expand Down
82 changes: 37 additions & 45 deletions tests/dsls/minikanren-binding-space.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -64,40 +64,30 @@
(~> (name:id arg ...)
(with-syntax ([#%rel-app (datum->syntax this-syntax '#%rel-app)])
#'(#%rel-app name arg ...)))))

(define-syntax define-mk-syntax
(syntax-parser
[(_ name:id rhs:expr)
#:with spaced-name ((make-interned-syntax-introducer 'mk) (attribute name) 'add)
#'(define-syntax spaced-name rhs)]))


; Surface syntax
(define-mk-syntax conj
(goal-macro
(syntax-parser
[(_ g) #'g]
[(_ g1 g2 g* ...) #'(conj (conj2 g1 g2) g* ...)])))

(define-mk-syntax disj
(goal-macro
(syntax-parser
[(_ g) #'g]
[(_ g1 g* ...) #'(disj2 g1 (disj g* ...))])))

(define-mk-syntax fresh
(goal-macro
(syntax-parser
[(_ (x:id ...+) b ...+)
#'(fresh1 (x ...) (conj b ...))])))

(define-mk-syntax conde
(goal-macro
(syntax-parser
[(_ [g ...+] ...+)
#'(disj
(conj g ...)
...)])))
(define-extension conj goal-macro
(syntax-parser
[(_ g) #'g]
[(_ g1 g2 g* ...) #'(conj (conj2 g1 g2) g* ...)]))

(define-extension disj goal-macro
(syntax-parser
[(_ g) #'g]
[(_ g1 g* ...) #'(disj2 g1 (disj g* ...))]))

(define-extension fresh goal-macro
(syntax-parser
[(_ (x:id ...+) b ...+)
#'(fresh1 (x ...) (conj b ...))]))

(define-extension conde goal-macro
(syntax-parser
[(_ [g ...+] ...+)
#'(disj
(conj g ...)
...)]))

(syntax-spec
(host-interface/definition
Expand All @@ -112,9 +102,10 @@
(define-relation/stub appendo)

(define expanded
(expand-nonterminal/datum goal
(fresh (l1 l2 l3)
(conde
(expand-nonterminal/datum
goal
(fresh (l1 l2 l3)
(conde
[(== l1 '()) (== l3 l2)] ; base case
[(fresh (head rest result) ; recursive case
(== (cons head rest) l1)
Expand All @@ -124,12 +115,12 @@
(check-equal?
expanded
'(fresh1 (l1 l2 l3)
(disj2
(conj2 (== (#%term-ref l1) '()) (== (#%term-ref l3) (#%term-ref l2)))
(fresh1 (head rest result)
(conj2 (conj2 (== (cons (#%term-ref head) (#%term-ref rest)) (#%term-ref l1))
(== (cons (#%term-ref head) (#%term-ref result)) (#%term-ref l3)))
(#%rel-app appendo (#%term-ref rest) (#%term-ref l2) (#%term-ref result)))))))
(disj2
(conj2 (== (#%term-ref l1) '()) (== (#%term-ref l3) (#%term-ref l2)))
(fresh1 (head rest result)
(conj2 (conj2 (== (cons (#%term-ref head) (#%term-ref rest)) (#%term-ref l1))
(== (cons (#%term-ref head) (#%term-ref result)) (#%term-ref l3)))
(#%rel-app appendo (#%term-ref rest) (#%term-ref l2) (#%term-ref result)))))))

; Test interposition point; separate submodule so we can rename-in the core #%rel-app.
(module* test racket
Expand All @@ -144,12 +135,13 @@
(core-#%rel-app name arg ...))])))

(check-equal?
(expand-nonterminal/datum goal
(fresh (l1 l2 l3)
(appendo l1 l2 l3)))
(expand-nonterminal/datum
goal
(fresh (l1 l2 l3)
(appendo l1 l2 l3)))
'(fresh1 (l1 l2 l3)
(fresh1 (foo)
(#%rel-app appendo (#%term-ref l1) (#%term-ref l2) (#%term-ref l3))))))
(fresh1 (foo)
(#%rel-app appendo (#%term-ref l1) (#%term-ref l2) (#%term-ref l3))))))



112 changes: 50 additions & 62 deletions tests/dsls/minikanren-rs2e/mk.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@

(provide (all-defined-out)
quote cons
(for-space mk quasiquote))
(for-space mk (all-defined-out)))

(require "../../../main.rkt"
ee-lib/errors
Expand Down Expand Up @@ -71,67 +71,55 @@

;; TODO: use syntax-parse and syntax classes for better errors.

(define-syntax define-syntax/space
(syntax-parser
[(_ name space rhs)
#`(define-syntax #,((make-interned-syntax-introducer (syntax-e #'space)) #'name) rhs)]))

(define-syntax/space quasiquote mk
(term-macro
(syntax-parser
[(~describe
"`<datum>"
(_ q))
(let recur ([stx #'q])
(syntax-parse stx #:datum-literals (unquote)
[(unquote e) #'e]
[(unquote . rest)
(raise-syntax-error 'unquote "bad unquote syntax" stx)]
[(a . d) #`(cons #,(recur #'a) #,(recur #'d))]
[(~or* v:identifier v:number) #'(quote v)]
[() #'(quote ())]))])))

(define-syntax disj
(goal-macro
(syntax-rules ()
((disj) fail)
((disj g) g)
((disj g0 g ...) (disj2 g0 (disj g ...))))))

(define-syntax conj
(goal-macro
(syntax-rules ()
((conj) succeed)
((conj g) g)
((conj g0 g ...) (conj2 g0 (conj g ...))))))

(define-syntax fresh
(goal-macro
(syntax-rules ()
((fresh () g ...) (conj g ...))
((fresh (x0 x ...) g ...)
(fresh1 (x0)
(fresh (x ...)
g ...))))))

(define-syntax conde
(goal-macro
(syntax-rules ()
((conde (g ...) ...)
(disj (conj g ...) ...)))))

(define-syntax conda
(goal-macro
(syntax-rules ()
((conda (g0 g ...)) (conj g0 g ...))
((conda (g0 g ...) ln ...)
(ifte g0 (conj g ...) (conda ln ...))))))

(define-syntax condu
(goal-macro
(syntax-rules ()
((condu (g0 g ...) ...)
(conda ((once g0) g ...) ...)))))
(define-extension quasiquote term-macro
(syntax-parser
[(~describe
"`<datum>"
(_ q))
(let recur ([stx #'q])
(syntax-parse stx #:datum-literals (unquote)
[(unquote e) #'e]
[(unquote . rest)
(raise-syntax-error 'unquote "bad unquote syntax" stx)]
[(a . d) #`(cons #,(recur #'a) #,(recur #'d))]
[(~or* v:identifier v:number) #'(quote v)]
[() #'(quote ())]))]))

(define-extension disj goal-macro
(syntax-rules ()
((disj) fail)
((disj g) g)
((disj g0 g ...) (disj2 g0 (disj g ...)))))

(define-extension conj goal-macro
(syntax-rules ()
((conj) succeed)
((conj g) g)
((conj g0 g ...) (conj2 g0 (conj g ...)))))

(define-extension fresh goal-macro
(syntax-rules ()
((fresh () g ...) (conj g ...))
((fresh (x0 x ...) g ...)
(fresh1 (x0)
(fresh (x ...)
g ...)))))

(define-extension conde goal-macro
(syntax-rules ()
((conde (g ...) ...)
(disj (conj g ...) ...))))

(define-extension conda goal-macro
(syntax-rules ()
((conda (g0 g ...)) (conj g0 g ...))
((conda (g0 g ...) ln ...)
(ifte g0 (conj g ...) (conda ln ...)))))

(define-extension condu goal-macro
(syntax-rules ()
((condu (g0 g ...) ...)
(conda ((once g0) g ...) ...))))

;;
;; Interface macros
Expand Down

0 comments on commit 31e0839

Please sign in to comment.