syntax/parse: add datum-to-expression helper

racket/collects/syntax/parse/private/datum-to-expr.rkt

@@ -0,0 +1,41 @@
+#lang racket/base
+(provide datum->expression)
+
+;; datum->expression : Datum -> Syntax[Expr]
+;; Produces code that evaluates (at same phase!) to an equivalent value.
+;; (Note: to produce phase-0 expr from phase-1 value, this module would
+;; need to require racket/base for-template.)
+(define (datum->expression v)
+  (define (const v) `(quote ,v))
+  (define (const? e) (and (pair? e) (eq? (car e) 'quote)))
+  (define (loop v)
+    (cond [(syntax? v)
+           `(quote-syntax ,v)]
+          [(pair? v)
+           (cond [(and (list? v) (andmap syntax? v))
+                  `(syntax->list (quote-syntax ,(datum->syntax #f v)))]
+                 [else
+                  (define outer-v v)
+                  (let pairloop ([v v] [acc null])
+                    (cond [(pair? v)
+                           (pairloop (cdr v) (cons (loop (car v)) acc))]
+                          [(null? v)
+                           (cond [(andmap const? acc) (const outer-v)]
+                                 [else `(list ,@(reverse acc))])]
+                          [else
+                           (let ([acc (cons (loop v) acc)])
+                             (cond [(andmap const? acc) (const outer-v)]
+                                   [else `(list* ,@(reverse acc))]))]))])]
+          [(vector? v)
+           (let ([elem-es (map loop (vector->list v))])
+             (cond [(andmap const? elem-es) (const v)]
+                   [else `(vector ,@elem-es)]))]
+          [(prefab-struct-key v)
+           => (lambda (key)
+                (define elem-es (map loop (cdr (vector->list (struct->vector v)))))
+                (cond [(andmap const? elem-es) (const v)]
+                      [else `(make-prefab-struct (quote ,key) ,@elem-es)]))]
+          ;; FIXME: boxes, hashes?
+          [else
+           (const v)]))
+  (datum->syntax #'here (loop v)))