#lang scheme/base
(provide
 (all-defined-out)
 (all-from-out syntax/stx))
(require
 syntax/stx)


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

(define (->sexp x)
  (cond
   ((syntax? x) (syntax->datum x))
   ((list? x)   (map ->sexp x))
   (else x)))


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

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

(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)
    (datum->syntax stx-lex
                   (syntax->datum stx)
                   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))))