#lang scheme/base

(require (for-syntax scheme/base))

(require syntax/stx)

(provide (all-defined-out))

(define (syntax-map fn stx)
  (if (stx-null? stx)
      stx
      (cons (fn (stx-car stx))
            (syntax-map fn (stx-cdr stx)))))

(define (syntax-append-map fn stx)
  (if (stx-null? stx)
      stx
      (apply append (syntax-map fn stx))))

(define (symbolic-identifier=? id1 id2)
  (eq? (syntax->datum id1)
       (syntax->datum id2)))

(define (atom->string atom)
  (cond
    [(string? atom) atom]
    [(symbol? atom) (symbol->string atom)]
    [(number? atom) (number->string atom)]
    [(syntax? atom) (atom->string (syntax->datum atom))]
    [else (error "Expected (syntax of) symbol, string or number. "
                 "Received: " atom)]))

(define (make-syntax-symbol stx . args)
  (datum->syntax stx (string->symbol (apply string-append (map atom->string args)))))

;; (_ (define ...) ...)
(define-syntax (begin-for-syntax/any-order stx)
  (define (expand-definition-name stx)
    (syntax-case stx (define)
      [(define (name arg ...) expr ...) #'name]
      [(define name expr)               #'name]))
  (define (expand-definition stx)
    (syntax-case stx (define)
      [(define (name arg ...) expr ...) #'(name (lambda (arg ...) expr ...))]
      [(define name expr)               #'(name expr)]))
  (syntax-case stx ()
    [(_ definition ...)
     (let* ([definitions    (syntax->list #'(definition ...))]
            [names          (map expand-definition-name definitions)]
            [letrec-clauses (map expand-definition definitions)])
       #`(define-values-for-syntax #,names
           (letrec #,letrec-clauses
             (values #,@names))))]))