Create version 2

examples.rkt

@@ -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))

generic-syntax-expanders.rkt

@@ -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))

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))))]))

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])

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]))

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))))

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)

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))

generic-syntax-expanders/info.rkt

@@ -0,0 +1,4 @@
+#lang info
+
+(define name "package-name")
+(define scribblings '(("package-name.scrbl" ())))

generic-syntax-expanders/main.rkt

@@ -0,0 +1,6 @@
+#lang racket
+
+(require mischief)
+
+(require/provide "define-expanders.rkt"
+                 "scoped-transformers.rkt")

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"]

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 ...))]))

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))

info.rkt

@@ -1,5 +1,8 @@
 #lang info
 
-(define name "generic-syntax-expanders")
+(define collection 'multi)
-(define deps '("base" "predicates" "scribble-lib"))
+(define deps '("base" "rackunit-lib"))
-(define scribblings '(("scribblings.scrbl")))
+(define build-deps '("cover"
+                     "scribble-lib"
+                     "rackunit-lib"
+                     "racket-doc"))

main.rkt

@@ -1,5 +0,0 @@
-#lang racket
-
-(require "generic-syntax-expanders.rkt")
-
-(provide (all-from-out "generic-syntax-expanders.rkt"))

scribblings.scrbl

@@ -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.
-}
-}

stx-utils.rkt

@@ -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))
-