diff --git a/examples.rkt b/examples.rkt deleted file mode 100644 index 05d4c6b..0000000 --- a/examples.rkt +++ /dev/null @@ -1,21 +0,0 @@ -#lang racket - -(require (for-syntax syntax/parse)) - -(require generic-syntax-expanders) - -(define-syntax-with-expanders blah - (syntax-parser - [(_ (any ...)) - #'(begin (foo any) ...)])) - -(define-blah-expander baz - (syntax-parser - [(_ n:number) - #`(#,@(build-list (syntax-e #'n) values))])) - -(expand-once #'(blah (1 2 3 4 5))) -;; => expands to (begin (foo 1) (foo 2) (foo 3) (foo 4) (foo 5)) - -(expand-once #'(blah (baz 5))) -;; => expands to (begin (foo 0) (foo 1) (foo 2) (foo 3) (foo 4)) diff --git a/generic-syntax-expanders.rkt b/generic-syntax-expanders.rkt deleted file mode 100644 index 7a0c08b..0000000 --- a/generic-syntax-expanders.rkt +++ /dev/null @@ -1,47 +0,0 @@ -#lang racket - -(require syntax/parse/define - (for-syntax syntax/parse - "stx-utils.rkt")) - -(provide define-syntax-with-expanders) - -(define-syntax define-syntax-with-expanders - (syntax-parser - [(_ foo:id transformer-expr) - (with-derived-ids ([foo-expander "~a-expander" #'foo] - [foo-expander? "~a-expander?" #'foo] - [foo-expander-transformer "~a-expander-transformer" #'foo] - [define-foo-expander "define-~a-expander" #'foo]) - #'(begin - (define-expander-struct foo-expander) - (define-expander-definer define-foo-expander foo-expander) - (define-syntax foo - (compose transformer-expr - (stx-expander - (syntax-list-with-head? (identifier-bound-to? foo-expander?)) - (λ (expander-stx) - (call-expander foo-expander-transformer - (car (syntax->list expander-stx)) - expander-stx)))))))])) - -;; Helpers for define-syntax-with-expanders - -;; Binds id as a struct at phase level 1 that will contain a single field named "transformer" -;; that is a procedure accepting a syntax object and returning a syntax object -(define-simple-macro (define-expander-struct id:id) - (begin-for-syntax - (struct id (transformer)))) - -;; Binds definer-id as a form that defines expanders for another syntactic form by using the -;; phase level 1 struct created with define-expander-struct -(define-simple-macro (define-expander-definer definer-id:id expander-struct-id:id) - (define-simple-macro (definer-id expander:id transformer) - (define-syntax expander - (expander-struct-id transformer)))) - -;; Small helper that assumes expander-stx is an identifier bound to an expander struct value -;; at phase level 1, and extracts the expander's transformer procedure with accessor then -;; calls that transformer on stx-to-expand -(define-for-syntax (call-expander accessor expander-stx stx-to-expand) - ((accessor (syntax-local-value expander-stx)) stx-to-expand)) \ No newline at end of file diff --git a/generic-syntax-expanders/define-expanders.rkt b/generic-syntax-expanders/define-expanders.rkt new file mode 100644 index 0000000..e58378b --- /dev/null +++ b/generic-syntax-expanders/define-expanders.rkt @@ -0,0 +1,30 @@ +#lang racket + +(require (for-syntax syntax/parse + "expander-types.rkt" + "expanders.rkt" + "with-identifiers.rkt")) + +(provide define-expander-type) + +(define-syntax define-expander-type + (syntax-parser + [(_ name:id) + (with-derived-ids #'name ([?-expander-type "~a-expander-type"] + [make-?-expander "make-~a-expander"] + [?-expander? "~a-expander?"] + [?-expander-stx? "~a-expander-stx?"] + [define-?-expander "define-~a-expander"] + [expand-all-?-expanders "expand-all-~a-expanders"]) + #'(begin + (define-for-syntax ?-expander-type (make-expander-type)) + (define-for-syntax (make-?-expander transformer) + (expander ?-expander-type transformer)) + (define-for-syntax (?-expander? v) + (expander-of-type? ?-expander-type v)) + (define-for-syntax (?-expander-stx? v) + (expander-stx-of-type? ?-expander-type v)) + (define-syntax-rule (define-?-expander expander-name transformer) + (define-syntax expander-name (make-?-expander transformer))) + (define-for-syntax (expand-all-?-expanders stx) + (expand-syntax-tree-with-expanders-of-type ?-expander-type stx))))])) diff --git a/generic-syntax-expanders/example-my-cond.rkt b/generic-syntax-expanders/example-my-cond.rkt new file mode 100644 index 0000000..5e9033e --- /dev/null +++ b/generic-syntax-expanders/example-my-cond.rkt @@ -0,0 +1,23 @@ +#lang racket + +(require "main.rkt" + lenses + racket/match + (for-syntax syntax/parse)) + +(define-expander-type cond) + +(define-syntax my-cond + (compose + (syntax-parser + [(_ cond-clause ...) + #'(cond cond-clause ...)]) + expand-all-cond-expanders)) + +(define-cond-expander $m + (syntax-parser + [(_ val pat body ...) + #'[(match val [pat #t] [_ #f]) (match val [pat body ...])]])) + +(my-cond [$m '(1 2 3) (list a b c) (+ a b c)] + [else 'bar]) \ No newline at end of file diff --git a/generic-syntax-expanders/example.rkt b/generic-syntax-expanders/example.rkt new file mode 100644 index 0000000..de26c3d --- /dev/null +++ b/generic-syntax-expanders/example.rkt @@ -0,0 +1,18 @@ +#lang racket + +(require "main.rkt" + (for-syntax syntax/parse)) + +(provide foo-bar + foo-blah + (for-syntax expand-all-foo-expanders)) + +(define-expander-type foo) + +(define-foo-expander foo-bar + (syntax-parser + [(_ a b c) #'b])) + +(define-foo-expander foo-blah + (syntax-parser + [(_ ...) #'blah])) diff --git a/generic-syntax-expanders/example2.rkt b/generic-syntax-expanders/example2.rkt new file mode 100644 index 0000000..eef44f5 --- /dev/null +++ b/generic-syntax-expanders/example2.rkt @@ -0,0 +1,6 @@ +#lang racket + +(require "example.rkt") + +(begin-for-syntax + (displayln (expand-all-foo-expanders #'(foo-bar 1 (foo-bar 'a 'b 'c) 3)))) diff --git a/generic-syntax-expanders/expander-types.rkt b/generic-syntax-expanders/expander-types.rkt new file mode 100644 index 0000000..8018bd3 --- /dev/null +++ b/generic-syntax-expanders/expander-types.rkt @@ -0,0 +1,29 @@ +#lang racket + +(require fancy-app + predicates + point-free) + +(provide + (contract-out + [expander-type? predicate/c] + [make-expander-type (-> expander-type?)] + [make-union-expander-type (->* (expander-type?) () #:rest expander-type? expander-type?)] + [expander-type-includes? (-> expander-type? expander-type? boolean?)])) + +(define (type-includes? symtree-type1 symtree-type2) + (define flat-type1 (flatten symtree-type1)) + (define flat-type2 (flatten symtree-type2)) + (true? (ormap (member _ flat-type1) flat-type2))) + +(struct expander-type (symtree-type) #:prefab) + +(define (make-expander-type) + (expander-type (gensym))) + +(define (make-union-expander-type . expander-types) + (define symtree-types (map expander-type-symtree-type expander-types)) + (expander-type symtree-types)) + +(define/wind-pre* expander-type-includes? + type-includes? expander-type-symtree-type) diff --git a/generic-syntax-expanders/expanders.rkt b/generic-syntax-expanders/expanders.rkt new file mode 100644 index 0000000..2153b1d --- /dev/null +++ b/generic-syntax-expanders/expanders.rkt @@ -0,0 +1,53 @@ +#lang racket + +(require "expander-types.rkt" + syntax/parse + syntax/stx + predicates + fancy-app) + +(provide (struct-out expander) + (contract-out + [expander-of-type? (-> expander-type? expander? boolean?)] + [expander-stx-of-type? (-> expander-type? expander-stx? boolean?)] + [expand-syntax-tree-with-expanders-of-type (-> expander-type? syntax? syntax?)])) + +(define (maybe-syntax-local-value stx) + (syntax-local-value stx (λ () #f))) + +(struct expander (type transformer)) + +(define (expander-of-type? type expander) + (expander-type-includes? type (expander-type expander))) + +(define (expander-stx? v) + (and (syntax? v) + (syntax-parse v + [(id:id _ ...) (expander? (maybe-syntax-local-value #'id))] + [_ #f]))) + +(define (expander-stx->expander expander-stx) + (syntax-parse expander-stx + [(id:id _ ...) (maybe-syntax-local-value #'id)])) + +(define (expander-stx-of-type? type v) + (and (expander-stx? v) + (expander-of-type? type (expander-stx->expander v)))) + +(define (expand-syntax-tree fully-expanded-node? expand-syntax-once stx) + (if (fully-expanded-node? stx) + (syntax-parse stx + [(a ...) (datum->syntax stx (stx-map (expand-syntax-tree fully-expanded-node? expand-syntax-once _) #'(a ...)))] + [a #'a]) + (expand-syntax-tree fully-expanded-node? expand-syntax-once (expand-syntax-once stx)))) + +(define (call-expander-transformer expander-stx) + (define expander (expander-stx->expander expander-stx)) + (define transformer (expander-transformer expander)) + (transformer expander-stx)) + +(define (expand-syntax-tree-with-expanders-of-type type stx) + (define not-expander-stx-of-type? (not? (expander-stx-of-type? type _))) + (expand-syntax-tree not-expander-stx-of-type? + call-expander-transformer + stx)) \ No newline at end of file diff --git a/generic-syntax-expanders/info.rkt b/generic-syntax-expanders/info.rkt new file mode 100644 index 0000000..3b59693 --- /dev/null +++ b/generic-syntax-expanders/info.rkt @@ -0,0 +1,4 @@ +#lang info + +(define name "package-name") +(define scribblings '(("package-name.scrbl" ()))) \ No newline at end of file diff --git a/generic-syntax-expanders/main.rkt b/generic-syntax-expanders/main.rkt new file mode 100644 index 0000000..e0ca77d --- /dev/null +++ b/generic-syntax-expanders/main.rkt @@ -0,0 +1,6 @@ +#lang racket + +(require mischief) + +(require/provide "define-expanders.rkt" + "scoped-transformers.rkt") diff --git a/generic-syntax-expanders/package-name.scrbl b/generic-syntax-expanders/package-name.scrbl new file mode 100644 index 0000000..8d71f3e --- /dev/null +++ b/generic-syntax-expanders/package-name.scrbl @@ -0,0 +1,16 @@ +#lang scribble/manual + +@(require scribble/eval + (for-label package-name + racket/base)) + +@title{package-name} + +@(define the-eval (make-base-eval)) +@(the-eval '(require "main.rkt")) + +@defmodule[package-name] + +@author[@author+email["Jack Firth" "jackhfirth@gmail.com"]] + +source code: @url["https://github.com/jackfirth/package-name"] \ No newline at end of file diff --git a/generic-syntax-expanders/scoped-transformers.rkt b/generic-syntax-expanders/scoped-transformers.rkt new file mode 100644 index 0000000..7553f77 --- /dev/null +++ b/generic-syntax-expanders/scoped-transformers.rkt @@ -0,0 +1,28 @@ +#lang racket + +(require (for-syntax racket/match + lenses)) + +(provide define-syntax-with-scoped-pre-transformers + (for-syntax with-scoped-pre-transformer + with-scoped-pre-transformers)) + +(define-for-syntax ((with-scoped-pre-transformer transformer stx-lens pre-transformer) stx) + (transformer (lens-transform stx-lens pre-transformer stx))) + +(define-for-syntax (with-scoped-pre-transformers transformer pre-transformer-lens-pairs) + (match pre-transformer-lens-pairs + ['() transformer] + [(list (list stx-lens pre-transformer) rest ...) + (with-scoped-pre-transformers (with-scoped-pre-transformer stx-lens transformer) rest)])) + +(define-syntax define-syntax-with-scoped-pre-transformers + (syntax-rules () + [(_ name ([stx-lens pre-transformer] ...) transformer-expr) + (define-syntax name + (with-scoped-pre-transformers transformer-expr + (list (list stx-lens pre-transformer) ...)))] + [(_ (name stx) ([stx-lens pre-transformer] ...) transformer-body ...) + (define-syntax-with-scoped-pre-transformers name + ([stx-lens pre-transformer] ...) + (lambda (stx) transformer-body ...))])) diff --git a/generic-syntax-expanders/with-identifiers.rkt b/generic-syntax-expanders/with-identifiers.rkt new file mode 100644 index 0000000..54ff51f --- /dev/null +++ b/generic-syntax-expanders/with-identifiers.rkt @@ -0,0 +1,17 @@ +#lang racket + +(require syntax/parse/define + racket/syntax) + +(provide with-formatted-ids + with-derived-ids) + +(define-simple-macro (with-formatted-ids ([pat-id:id format base-id-stx] ...) stx-expr) + (with-syntax ([pat-id + (format-id base-id-stx + format + base-id-stx)] ...) + stx-expr)) + +(define-simple-macro (with-derived-ids base-id-stx ([pat-id:id format] ...) stx-expr) + (with-formatted-ids ([pat-id format base-id-stx] ...) stx-expr)) diff --git a/info.rkt b/info.rkt index 1d63906..de3d668 100644 --- a/info.rkt +++ b/info.rkt @@ -1,5 +1,8 @@ #lang info -(define name "generic-syntax-expanders") -(define deps '("base" "predicates" "scribble-lib")) -(define scribblings '(("scribblings.scrbl"))) \ No newline at end of file +(define collection 'multi) +(define deps '("base" "rackunit-lib")) +(define build-deps '("cover" + "scribble-lib" + "rackunit-lib" + "racket-doc")) \ No newline at end of file diff --git a/main.rkt b/main.rkt deleted file mode 100644 index 0f35b39..0000000 --- a/main.rkt +++ /dev/null @@ -1,5 +0,0 @@ -#lang racket - -(require "generic-syntax-expanders.rkt") - -(provide (all-from-out "generic-syntax-expanders.rkt")) \ No newline at end of file diff --git a/scribblings.scrbl b/scribblings.scrbl deleted file mode 100644 index b7e23de..0000000 --- a/scribblings.scrbl +++ /dev/null @@ -1,18 +0,0 @@ -#lang scribble/manual - -@(require "generic-syntax-expanders.rkt") - -@title{Generic Syntax Expanders} -@defmodule[generic-syntax-expanders] - -@defform[(define-syntax-with-expanders id transformer-expr)]{ -Defines @racket[id] as syntax, but also defines several additional bindings that allow -for additional syntax to be defined within the body of wherever @racket[id] is used, -in the same way @racket[define-match-expander] allows for additional syntax to be -defined in the body of @racket[match] patterns. The bindings defined are as follows: -@defsubform[(define-id-expander expander-id expander-transformer-expr)]{ -A syntactic form that binds @racket[expander-id] as a @racket[id-expander?], which -will expand within the body of an @racket[id] syntactic form using -@racket[expander-transformer-expr] before @racket[id] expands. -} -} \ No newline at end of file diff --git a/stx-utils.rkt b/stx-utils.rkt deleted file mode 100644 index 0ba5782..0000000 --- a/stx-utils.rkt +++ /dev/null @@ -1,50 +0,0 @@ -#lang racket - -(require predicates - racket/syntax - syntax/parse - syntax/parse/define) - -(provide with-derived-ids - identifier-bound-to? - stx-expander - syntax-list-with-head?) - -(define (disp a) (displayln a) a) - -;; Takes a predicate p and produces a predicate satisfied by syntax objects -;; which are identifiers bound to values satisfying p -(define (identifier-bound-to? p) - (and? identifier? - (compose p maybe-syntax-local-value))) - -(define (syntax-list-with-head? . ps) - (compose (apply list-with-head? ps) - syntax->list)) - -;; Falsey non-throwing verison of syntax-local-value -(define (maybe-syntax-local-value stx) - (syntax-local-value stx (λ () #f))) - -;; Takes a syntax-object predicate and a syntax transformer, then returns -;; a procedure that parses a syntax object and determines at each level of -;; the syntax tree if that subtree satisfies the predicate. If it does, -;; that subtree is replaced with the result of (transformer subtree-stx) -(define ((stx-expander expand? transformer) stx) - (if (expand? stx) - (transformer stx) - (syntax-parse stx - [(a . b) #`(#,((stx-expander expand? transformer) #'a) - #,@((stx-expander expand? transformer) #'b))] - [() #'()] - [a #'a]))) - -;; Shorthand for adding new identifiers based on other formatted ones to -;; syntax patterns -(define-simple-macro (with-derived-ids ([pat-id:id format base-id-stx] ...) stx-expr) - (with-syntax ([pat-id - (format-id base-id-stx - format - base-id-stx)] ...) - stx-expr)) -