(in-package :cl-user)

#|
URIs are interned. 

Syntax for reading uris:

Short form
!foo -> (make-uri-base-relative "foo") makes a uri relative to *default-uri-base*
!ex:foo -> uses *namespace-replacements* to expand uri
!"short form" to take advantage of lisp character quoting for the above(you need to quote ":" as "\:"

Long form
!<http://www.example.com/#foo> reads everything until the ">" You need to do the proper uri escaping. 

To construct a uri:

(make-uri full-name &optional abbreviation) e.g. (make-uri "http://example.com/foo") -> !ex:foo
(make-uri-base-relative "foo" "ex:") -> !ex:foo

To make a uri alias:
(def-uri-alias "material-entity" !<http://purl.obofoundry.org/obo/OBI_0000141>)
Which can then be used as !material-entity

|#


(defstruct (uri  (:print-function print-uri) (:constructor internal-make-uri (full &optional abbreviated)))
  full
  abbreviated)

(defparameter *interned-uris* (make-hash-table :test 'equal))

(defparameter *default-uri-base* "http://example.com/")

(defun make-uri-base-relative (string &optional (base *default-uri-base*))
  (let ((lastchar (char base (1- (length base)))))
    (if (eql lastchar #\:)
	(let ((concat (format nil "~a~a" base string)))
	  (make-uri  (unabbreviate-namespace concat) concat))
	(make-uri (format nil "~a~a" base string)))))

(defun get-uri-alias-or-make-uri-base-relative (string)
  (or (gethash string *interned-uris*)
      (make-uri-base-relative string)))

(defun make-uri (string &optional abbreviation &rest format-args)
  (cond ((uri-p string)
	 string)
	((and (null string) (null abbreviation))
	 (internal-make-uri "bnode" "bnode")) ;; FIXME. How to return a bnode? GetURI returns null
	(t 
	 (when (equal abbreviation "blank:")
	   (setq abbreviation (format nil "blank:~a" (incf *blankcounter*))))
	 (if string
	     (when format-args
	       (setq string (apply 'format nil string format-args)))
	     (setq string (unabbreviate-namespace
			   (if format-args
			       (setq abbreviation (apply 'format nil abbreviation format-args))
			       abbreviation))))
	 (or (gethash string *interned-uris*)
	     (setf (gethash string *interned-uris*)
		   (internal-make-uri string abbreviation))))))

(defun def-uri-alias (string uri)
  (setf (gethash string *interned-uris*) uri))

(defmethod make-load-form ((object uri) &optional environment)
  (declare (ignore environment))
  `(make-uri ,(uri-full object) ,(uri-abbreviated object)))

(defun print-uri (object stream depth)
  (let ((abbreviated (uri-abbreviated object))
	(full (uri-full object)))
    (if abbreviated
      (format stream "!~a" abbreviated)
      (let ((abbreviated (maybe-abbreviate-namespace full)))
	(if (eq abbreviated full)
	    (format stream "!<~a>" full)
	    (progn
	      (setf (uri-abbreviated object) abbreviated) 
	      (format stream "!~a" abbreviated)))))))

(defun decache-uri-abbreviated ()
  (maphash (lambda(s u) (setf (uri-abbreviated u) nil)) *interned-uris*))

(defun full-uri-string (uri)
  (uri-full uri))

(defun read-uri (stream char)
  (declare (ignore char))
  (when (eql char #\<) (unread-char #\< stream))
  (let ((peek (peek-char nil stream nil :eof)))
    (let ((string
	   (cond ((eql peek #\")
		  (read stream))
		 ((eql peek #\<)
		  (read-char stream)
		  (return-from read-uri
		    `(make-uri 
		      ,(coerce 
			(loop for char = (peek-char nil stream nil :eof)
			   while (not (or (eq char :eof)
					;		(system::whitespacep char)
					  (eql char #\>)))
			   collect (read-char stream)
			   finally (when (not (eql (read-char stream) #\>)) 
				     (error "Unterminated URI: Missing >"))) 
			'string))))
		 (t
		  (coerce 
		   (loop for char = (peek-char nil stream nil :eof)
		      while (not (or (eq char :eof)
				     (system::whitespacep char)
				     (char= char #\))))
		      collect (read-char stream))
		   'string))
		 )))
      (if (find #\: string)
	  `(make-uri nil ,string)
	  `(get-uri-alias-or-make-uri-base-relative ,string)))))

(set-macro-character #\! 'read-uri t)

(defun get-uri-alias (string)
  (gethash string *interned-uris*))

(defun eval-uri-reader-macro (form)
  "The reader macro doesn't evaluate anything at reader time. If you do '(!ex:foo) you get
 ((MAKE-URI NIL \"ex:foo\")). This function takes a form and evaluates just those make-uri
calls, so you can get what you probably wanted: (type-of (car (eval-uri-reader-macro '(!ex:foo)))) ->uri"
  (cond ((and (consp form) (member (car form) '(make-uri make-uri-base-relative get-uri-alias-or-make-uri-base-relative)))
	 (apply (car form) (cdr form)))
	((consp form) (mapcar #'eval-uri-reader-macro form))
	(t form)))

(defparameter *uri-workaround-character-fixes* 
  (load-time-value
   (loop for fixme in '(#\& #\  #\( #\)  )
      collect (list (#"compile" '|java.util.regex.Pattern| (format nil "[~c]" fixme))
		    (format nil "%~2x" (char-code fixme)) fixme))))

(defun clean-uri (site path &optional (protocol "http" ) (fragment "") (query nil))
  (let ((null (load-time-value (make-immediate-object nil :ref))))
    (clean-string
     (#0"toString" (new 'java.net.uri protocol site path (or query null) (or fragment null))))))

(defun clean-string (string)
  (loop for (pattern replacement) in *uri-workaround-character-fixes*
       for new = 
       (#0"replaceAll" (#0"matcher" pattern string) replacement)
       then
       (#0"replaceAll" (#0"matcher" pattern new) replacement)
       finally (return  (#"toString" new)) ))

(eval-when (:load-toplevel :execute)
  (when (boundp '*print-db-hooks*)
    (pushnew 'eval-uri-reader-macro *print-db-hooks*)))