;;; -*- Mode: Scheme; pseudoscheme-package: SCHEME -*-

;;;; Pseudoscheme URI Support

(define (read-uri port char)
  (define (finish-string string)
    ;++ These should generate expressions; see the README for why they
    ;++ don't at the moment.
    (if (cl:find #\: string)
        (cl-user::make-uri '() string)
        (cl-user::make-uri-base-relative string)))
  (if (eqv? char #\<)
      (cl:unread-char #\< port))
  (let ((char (peek-char port)))
    (if (eof-object? char)
        (error "Premature EOF after URI in ~S." port)
        (case char
          ((#\") (finish-string (read port)))
          ;++ Alan's Common Lisp code also returns a URI
          ;++ here, not an expression that yields one.
          ((#\<) (cl-user::make-uri (read-uri/full port)))
          (else (finish-string (read-uri/abbreviated port)))))))

(define (read-uri/full port)
  (read-char port)
  (let loop ((chars '()))
    (let ((char (read-char port)))
      (cond ((eof-object? char)
             (error "Unterminated URI from ~S: Missing > after `~A'"
                    port
                    (list->string (reverse chars))))
            ((eqv? char #\>)
             (list->string (reverse chars)))
            (else
             (loop (cons char chars)))))))

(define (read-uri/abbreviated port)
  (let loop ((chars '()))
    (let ((char (peek-char port)))
      (if (or (eof-object? char)
              (char-whitespace? char)
              ;; This seems kludgey!
              (char=? char #\) ))
          (list->string (reverse chars))
          (begin (read-char port) (loop (cons char chars)))))))

(cl:set-macro-character #\! read-uri 'cl:nil ps:scheme-readtable)