#lang scheme/base
(require scheme/contract
         (for-syntax scheme/base))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  SYNTAX OBJECTS
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (syntax-datum/c datum)
  (let* ([datum/c (coerce-contract datum datum)])
    (flat-named-contract (build-compound-type-name 'syntax-datum/c datum/c)
      (lambda (v)
        (and (syntax? v)
             ((flat-contract-predicate datum/c)
              (syntax->datum v)))))))

(define (syntax-listof/c elem)
  (let* ([elem/c (coerce-contract elem elem)])
    (flat-named-contract (build-compound-type-name 'syntax-listof/c elem/c)
      (lambda (v)
        (and (syntax? v)
             ((flat-contract-predicate (listof elem/c))
              (syntax->list v)))))))

(define (syntax-list/c . elems)
  (let* ([elem/cs (map (lambda (elem) (coerce-contract elem elem)) elems)])
    (flat-named-contract (apply build-compound-type-name 'syntax-list/c elem/cs)
      (lambda (v)
        (and (syntax? v)
             ((flat-contract-predicate (apply list/c elem/cs))
              (syntax->list v)))))))

(define (syntax-map f stx)
  (map f (syntax->list stx)))

(define (to-syntax datum
                   #:stx [stx #f]
                   #:src [src stx]
                   #:ctxt [ctxt stx]
                   #:prop [prop stx]
                   #:cert [cert stx])
  (datum->syntax ctxt datum src prop cert))

(define (to-datum v)
  (cond
   [(syntax? v) (to-datum (syntax-e v))]
   [(pair? v) (cons (to-datum (car v)) (to-datum (cdr v)))]
   [(vector? v)
    (make-vector (vector-length v) (lambda (i) (to-datum (vector-ref v i))))]
   [(prefab-struct-key v)
    =>
    (lambda (key)
      (let* ([vec (struct->vector v)]
             [lst (vector->list v)]
             [fields (cdr lst)]
             [data (map to-datum fields)])
        (apply make-prefab-struct key data)))]
   [else v]))

(define-syntax (with-syntax* stx)
  (syntax-case stx ()
    [(ws* (clause . rest) . body)
     (syntax/loc stx
       (with-syntax (clause) (ws* rest . body)))]
    [(ws* () . body)
     (syntax/loc stx
       (with-syntax () . body))]))

(define stx/f (or/c syntax? false/c))

(define current-syntax (make-parameter #f))

(define (syntax-error stx msg . args)
  (cond
   [(current-syntax) =>
    (lambda (stx*)
      (raise-syntax-error #f (apply format msg args) stx* stx))]
   [else (raise-syntax-error #f (apply format msg args) stx)]))

(provide/contract
 [syntax-datum/c (-> flat-contract/predicate? flat-contract?)]
 [syntax-listof/c (-> flat-contract/predicate? flat-contract?)]
 [syntax-list/c
  (->* [] [] #:rest (listof flat-contract/predicate?) flat-contract?)]
 [syntax-map (-> (-> syntax? any/c) (syntax-listof/c any/c) (listof any/c))]
 [to-syntax
  (->* [any/c]
       [#:stx stx/f #:src stx/f #:ctxt stx/f #:prop stx/f #:cert stx/f]
       syntax?)]
 [to-datum (-> any/c any/c)]
 [current-syntax (parameter/c (or/c syntax? false/c))]
 [syntax-error (->* [syntax? string?] [] #:rest list? none/c)])

(provide with-syntax*)