#lang racket/base
(require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context)
         syntax/strip-context racket/function racket/list racket/syntax)
(provide (all-defined-out) (all-from-out syntax/strip-context))


(define-syntax (syntax-match stx)
  (syntax-case stx (syntax)
    [(_ stx-arg [(syntax pattern) body ...] ...)
     #'(syntax-case stx-arg ()
         [pattern body ...] ...)]))

(define-syntax (inject-syntax stx)
  ;; todo: permit mixing of two-arg and one-arg binding forms
  ;; one-arg form allows you to inject an existing syntax object using its current name
  (syntax-case stx (syntax)
    [(_ ([(syntax sid) sid-stx] ...) body ...)
     #'(with-syntax ([sid sid-stx] ...) body ...)]
    ;; todo: limit `sid` to be an identifier
    [(_ ([sid] ...) body ...)
     #'(with-syntax ([sid sid] ...) body ...)]))

(define-syntax (inject-syntax* stx)
  (syntax-case stx ()
    [(_ () . body) #'(begin . body)]
    [(_ (stx-expr0 stx-expr ...) . body)
     #'(inject-syntax (stx-expr0)
         (inject-syntax* (stx-expr ...) . body))]))

(define-syntax syntax-let (make-rename-transformer #'inject-syntax))
(define-syntax add-syntax (make-rename-transformer #'inject-syntax))


(define (check-syntax-list-argument caller-name arg)
  (cond
    [(and (syntax? arg) (syntax->list arg))]
    [(list? arg) arg]
    [else (raise-argument-error caller-name "list of syntax, or syntaxed list" arg)]))


(define-syntax-rule (syntax-case-partition _stx-list _literals . _matchers)
  (partition (λ(stx-item)
               (with-handlers ([exn:fail:syntax? (λ (exn) #f)])
                 (syntax-case stx-item _literals
                   . _matchers))) (check-syntax-list-argument 'syntax-case-partition _stx-list)))


(define-syntax-rule (syntax-case-filter _stx-list _literals . _matchers)
  (filter (λ(stx-item)
            (with-handlers ([exn:fail:syntax? (λ (exn) #f)])
              (syntax-case stx-item _literals
                . _matchers))) (check-syntax-list-argument 'syntax-case-filter _stx-list)))


(define-syntax-rule (syntax-case-map _stx-list _literals . _matchers)
  (map (λ(stx-item)
         (syntax-case stx-item _literals
           . _matchers)) (check-syntax-list-argument 'syntax-case-map _stx-list)))


(define-syntax-rule (reformat-id fmt id0 id ...)
  (format-id id0 fmt id0 id ...))

(define-syntax-rule (format-string fmt id0 id ...)
  (datum->syntax id0 (format fmt (syntax->datum id0) (syntax->datum id) ...)))


(define-syntax-rule (->unsyntax x)
  (if (syntax? x)
      (syntax->datum x)
      x))

(define-syntax-rule (prefix-id _prefix ... _base)
  (format-id _base "~a~a" (string-append (format "~a" (->unsyntax _prefix)) ...) _base))

(define-syntax-rule (prefix-ids _prefix ... _bases)
  (syntax-case-map _bases ()
                   [_base (prefix-id _prefix ... #'_base)]))

(define-syntax-rule (infix-id _prefix _base _suffix ...)
  (format-id _base "~a~a~a" (->unsyntax _prefix) _base (string-append (format "~a" (->unsyntax _suffix)) ...)))

(define-syntax-rule (infix-ids _prefix _bases _suffix ...)
  (syntax-case-map _bases ()
                   [_base (infix-id _prefix #'_base _suffix ...)]))

(define-syntax-rule (suffix-id _base _suffix ...)
  (infix-id "" _base _suffix ...))

(define-syntax-rule (suffix-ids _bases _suffix ...)
  (infix-ids "" _bases _suffix ...))