Utils

Split out utils

stx-utils.rkt

@@ -0,0 +1,48 @@
+#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])))
+
+(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))
+