#lang scheme/base

(require (for-syntax scheme/base)
         scheme/contract
         scheme/match)

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

; syntax (U string symbol number syntax) ... -> syntax
(define (make-id 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))))]))

; syntax -> string
(define (syntax-location-string stx)
  ; string
  (define source
    (match (syntax-source stx)
      [(? path? src)
       (let-values ([(base name must-be-dir?) (split-path src)])
         name)]
      [(? string? src)
       (match (regexp-match #rx"[^\\/\\\\]+$" src)
         [(list filename) filename]
         [other "unknown.ss"])]
      [other "unknown.ss"]))
  ; (U integer "")
  (define line
    (or (syntax-line stx) ""))
  ; (U integer "")
  (define column
    (or (and (syntax-line stx) (syntax-column stx))
        (syntax-position stx)
        ""))
  ; string
  (format "~a:~a:~a" source line column))

; syntax -> boolean
(define-values (dotted-identifier? split-dotted-identifier)
  (let ([rx #rx"([^.][^.]*)[.](..*)"])
    (values (lambda (stx)
              (and (identifier? stx)
                   (let ([str (symbol->string (syntax->datum stx))])
                     (regexp-match rx str))
                   #t))
            (lambda (stx)
              (if (dotted-identifier? stx)
                  (let* ([str   (symbol->string (syntax->datum stx))]
                         [match (regexp-match rx str)])
                    (map (lambda (str)
                           (datum->syntax stx (string->symbol str)))
                         (cdr match)))
                  (raise-syntax-error #f "expected dotted identifier" stx))))))

; Helpers ----------------------------------------

; (U string symbol number syntax) -> string
(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) (U symbol string number), received: " atom)]))

; Provide statements -----------------------------

(provide begin-for-syntax/any-order)

(provide/contract
 [symbolic-identifier=?   (-> syntax? syntax? boolean?)]
 [make-id                 (->* ((or/c syntax? false/c)) ()
                               #:rest (listof (or/c string? symbol? number? syntax?))
                               syntax?)]
 [syntax-location-string  (-> syntax? string?)]
 [dotted-identifier?      (-> syntax? boolean?)]
 [split-dotted-identifier (-> syntax? (list/c syntax? syntax?))])