#lang scheme

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  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))

(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)])

(provide with-syntax*)