#lang scheme/base

(require (for-template "ml-package.ss"))

(provide syntax-append
         syntax-prepend
         unlong)

(define (syntax-append stx str)
  (datum->syntax
   stx
   (string->symbol
    (string-append
     (symbol->string
      (syntax-e stx))
     str))
   stx))

(define (syntax-prepend stx str)
  (datum->syntax
   stx
   (string->symbol
    (string-append
     str
     (symbol->string
      (syntax-e stx))))
   stx))

(define (find-identifier lst1 lst2 e)
  (cond ((null? lst1)
         (raise-syntax-error 'expand "unbound identifier" e))
        ((equal? (car lst1) e)
         (car lst2))
        (else
         (find-identifier (cdr lst1) (cdr lst2) e))))

(define (unlong p-list)
  (syntax-case p-list ()
    ((p)
     #'p)
    ((p0 p1 . rest)
     (let* ((exported-ids (map syntax-e (package-exported-identifiers #'p0)))
            (original-ids (package-original-identifiers #'p0))
            (p2 (find-identifier exported-ids original-ids (syntax-e #'p1))))
       (unlong #`(#,p2 . rest))))))