tools/stx.ss
#lang scheme/base
(provide
 (all-defined-out)
 (all-from-out syntax/stx))
(require
 scheme/struct-info
 syntax/stx)


(define (format-stx fmt . args)
  (apply format fmt (->sexp args)))
(define (map-stx fn . stxs)
  (apply map fn (map syntax->list stxs)))

;; FIXME: doesn't handle all cases (i.e. vectors..)
(define (->sexp x)
  (cond
   ((syntax? x) (syntax->datum x))
   ((list? x)   (map ->sexp x))
   ((pair? x)   (cons (->sexp (car x)) (->sexp (cdr x))))
   ((null? x)   '())
   (else x)))

(define ->syntax datum->syntax)
(define ->datum  syntax->datum)

(define (prefix-id . names)
  (let ((orig-stx (car (reverse names)))) ;; use original name info
    (->syntax orig-stx   ;; lexical context
              (string->symbol
               (apply string-append
                      (map
                       (lambda (x) (format "~a" (->datum x)))
                     names)))
              orig-stx   ;; source info
              )))

(define (stx-reverse stx)
  #`(#,@(reverse (syntax->list stx))))

(define (lexical-binding? stx)
  (eq? 'lexical (identifier-binding stx)))

(define (stx-uncons stx)
  (values (stx-car stx) (stx-cdr stx)))

(define (stx-length s)
  (length (->datum s)))

;; re-interpret lexical interpretation, keeping source location. can
;; be used for 'include' semantics.
(define (lexical-context-from stx-lex)
  (lambda (stx)
    (let ((new-stx
           (datum->syntax stx-lex
                          (syntax->datum stx)
                          stx)))
      ;; (printf "~a ~a ~a\n" (syntax->datum stx) (syntax-source stx) (syntax-source new-stx))
      new-stx)))


;; Expand all sub-expressions in a tree.
(define-syntax-rule (syntax-case/r tree-stx literals clause ...)
  (let down ((stx tree-stx))
    (syntax-case stx literals
      clause ...
      ((el (... ...))
       (map down (syntax->list #'(el (... ...)))))
      (el #'el))))
      


;; Structs

(define (struct->struct-info name [context name])
  (let ([v (syntax-local-value name (lambda () #f))])
    (unless (struct-info? v)
      (raise-syntax-error #f "identifier is not bound to a structure type" context name))
    (let ((v (extract-struct-info v)))
      (printf "~a\n" v)
      v)))

(define (struct->constructor . a) (cadr (apply struct->struct-info a)))
(define (struct->members . a)     (cadddr (apply struct->struct-info a)))


(define (in-stx stx) (in-list (syntax->list stx)))


;; Non-higienically introduce a collection of identifiers.
(define (datum->syntax-list stx lst)
  (map (lambda (x) (datum->syntax stx x)) lst))

(define-syntax-rule (syntax-introduce-identifiers stx lst body)
  (syntax-case (datum->syntax-list stx 'lst) ()
    (lst body)))