(in-package :util)

(defconstant +unspecific+
  (gensym "unspecific"))

(defmacro with-unique-names ((&rest bindings) &body body)
  "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*

Executes a series of forms with each VAR bound to a fresh,
uninterned symbol. The uninterned symbol is as if returned by a call
to GENSYM with the string denoted by X - or, if X is not supplied, the
string denoted by VAR - as argument.

The variable bindings created are lexical unless special declarations
are specified. The scopes of the name bindings and declarations do not
include the Xs.

The forms are evaluated in order, and the values of all but the last
are discarded \(that is, the body is an implicit PROGN)."
  `(let ,(mapcar (lambda (binding)
		   (multiple-value-bind (var x)
		       (if (consp binding)
			   (values (first binding) (second binding))
			   (values binding (string binding)))
		     (check-type var symbol)
		     `(,var (gensym (string ,x)))))
                 bindings)
         ,@body))

(defmacro rebinding (bindings &body body)
  "REBINDING ( { var | (var prefix) }* ) form*

Evaluates a series of forms in the lexical environment that is
formed by adding the binding of each VAR to a fresh, uninterned
symbol, and the binding of that fresh, uninterned symbol to VAR's
original value, i.e., its value in the current lexical environment.

The uninterned symbol is created as if by a call to GENSYM with the
string denoted by PREFIX - or, if PREFIX is not supplied, the string
denoted by VAR - as argument.

The forms are evaluated in order, and the values of all but the last
are discarded \(that is, the body is an implicit PROGN)."
  (loop for binding in bindings
        for var = (if (consp binding) (car binding) binding)
        for name = (gensym)
        collect `(,name ,var) into renames
        collect ``(,,var ,,name) into temps
        finally (return
		  `(let ,renames
		     (with-unique-names ,bindings
		       `(let (,,@temps)
			  ,,@body))))))

(defun gensymize-list (list)
  (loop for x in list
	for name = (gensym)
	collect name into new-list
	collect `(,name ,x) into bindings
	finally (return (values new-list bindings))))

(defmacro rebinding-lists (lists &body body)
  (labels ((expand (lists)
	     (if lists
		 (let ((list (pop lists)))
		   (with-unique-names (bindings)
		     `(multiple-value-bind (,list ,bindings) (gensymize-list ,list)
		        `(let ,,bindings
			   ,,(expand lists)))))
		 `(progn
		    ,@body))))
    (expand lists)))

(defun expand-collecting (list collect body)
  (with-unique-names (tail)
    `(let ((,list nil)
	   (,tail nil))
       (flet ((,collect (value)
		(prog1 value
		  (let ((cons (cons value nil)))
		    (if ,tail
			(setf (cdr ,tail) cons)
			(setf ,list cons))
		    (setf ,tail cons)))))
	 ,@body))))

(defmacro collecting (&body body)
  (with-unique-names (list)
    (expand-collecting list 'collect `(,@body ,list))))

(defmacro with-collections (collections &body body)
  (labels ((expand (collections)
	     (if collections
		 (destructuring-bind (list collect) (pop collections)
		   (expand-collecting list collect (list (expand collections))))
		 `(progn
		    ,@body))))
    (expand collections)))

(defmacro whereas (bindings &body body)
  (labels ((expand (bindings)
	     (if bindings
		 (let ((binding (pop bindings)))
		   `(let (,binding)
		      (when ,(first binding)
			,(expand bindings))))
		 `(progn
		    ,@body))))
    (expand bindings)))

(defun sans (plist &rest keys)
  "Returns PLIST with keyword arguments from KEYS removed."
  ;; stolen from Usenet posting <3247672165664225@naggum.no> by Erik
  ;; Naggum
  (let ((sans '()))
    (loop
      (let ((tail (nth-value 2 (get-properties plist keys))))
        ;; this is how it ends
        (unless tail
          (return (nreconc sans plist)))
        ;; copy all the unmatched keys
        (loop until (eq plist tail) do
              (push (pop plist) sans)
              (push (pop plist) sans))
        ;; skip the matched key
        (setq plist (cddr plist))))))

(defun macro-value (form &optional env default)
  (when (symbolp form) (setf form (list form)))
  (multiple-value-bind (expansion expanded-p) (macroexpand form)
    (if expanded-p
	expansion
	default)))

(defun maybe-get-output-stream-string (stream)
  #+gcl
  (when (plusp (length (si:output-stream-string stream)))
    (get-output-stream-string stream))
  #-gcl
  (let ((string (get-output-stream-string stream)))
    (when (plusp (length string))
      string)))

(defmacro with-output ((stream &optional (default '*standard-output*) block) &body body)
  (with-unique-names (string-stream-p)
    `(let ((,string-stream-p (eq ,stream nil)))
       (case ,stream
	 ((t) (setf ,stream ,default))
	 ((nil) (setf ,stream (make-string-output-stream))))
       (block ,block
	 ,@body)
       (when ,string-stream-p
	 (get-output-stream-string ,stream)))))

(defun whitespacep (object)
  (typecase object
    (character (char<= object #\Space))
    (sequence (every #'whitespacep object))
    (t nil)))

(defun string-trim-if (pred string)
  (cond
    ((whitespacep string) nil)
    ((= (length string) 1) string)
    (t (subseq string
	       (position-if-not pred string)
	       (1+ (position-if-not pred string :from-end t))))))

(defun remove-extra-spaces (string &key (space #\Space) (predicate #'whitespacep) stream)
  (with-output (stream)
    (loop for char across string
	  with state = :start
	  do (if (funcall predicate char)
		 (unless (eq state :start)
		   (setf state :space))
		 (progn
		   (when (eq state :space)
		     (write-char space stream))
		   (setf state :word)
		   (write-char char stream))))))

(defun method-exists (pattern fn &rest args)
  (whereas ((methods (compute-applicable-methods fn args)))
    (or (eq pattern t)
	(etypecase pattern
	  (list
	   (dolist (method methods)
	     (when (equal (method-qualifiers method) pattern)
	       (return t))))
	  ((or symbol function)
	   (member-if pattern methods))))))

(defmethod class-prototype ((name symbol))
  (class-prototype (find-class name)))

(defun string-to-object (string)
  (when (plusp (length string))
    #+gcl (si:string-to-object string)
    #-gcl (read-from-string string)))

(defun parse-method-definition (body)
  (loop for first = (first body)
	while (atom first)
	collect (pop body) into qualifiers
	finally (return (values qualifiers body))))

(defmacro destructuring-method-definition (lambda-list forms &body body)
  (let* ((tail (member '&qualifiers lambda-list))
	 (initial-lambda-list (ldiff lambda-list tail))
	 (qualifiers (second tail))
	 (lambda-list (cddr tail)))
    (rebinding (forms)
      `(,@(if initial-lambda-list
	      `(destructuring-bind (,@initial-lambda-list &rest ,forms) ,forms)
	      '(progn))
	(multiple-value-bind (,qualifiers ,forms) (parse-method-definition ,forms)
	  (destructuring-bind ,lambda-list ,forms
	    ,@body))))))

(defmacro define-method-macro (name lambda-list &body body)
  (with-unique-names (forms)
    `(defmacro ,name (&rest ,forms)
       (destructuring-method-definition ,lambda-list ,forms
	 ,@body))))

(defmacro with-caching-slot ((instance slot) &body body)
  (rebinding (instance slot)
    `(if (slot-boundp ,instance ,slot)
         (slot-value ,instance ,slot)
         (setf (slot-value ,instance ,slot)
	       (progn ,@body)))))

(defun sometree (pred object)
  (when object
    (if (consp object)
	(or (sometree pred (car object))
	    (sometree pred (cdr object)))
	(funcall pred object))))

(defmacro insertf (item sequence &rest args &environment env)
  (multiple-value-bind (vars vals store-vars writer reader) (get-setf-method sequence env)
    `(let* (,@(mapcar #'list vars vals)
	    (,(car store-vars) (if ,reader
				   (merge (type-of ,reader) ,reader (list ,item) ,@args)
				   (list ,item))))
       ,writer)))

(defmacro deletef (item sequence &rest args &environment env)
  (multiple-value-bind (vars vals store-vars writer reader) (get-setf-method sequence env)
    `(let* (,@(mapcar #'list vars vals)
	    (,(car store-vars) (delete ,item ,reader ,@args)))
       ,writer)))

(defun scale-bytes (byte-count &optional stream)
  (cond ((> byte-count (* 1024 1024 1024 1024))
	 (format stream "~,1f TB" (/ byte-count (* 1024 1024 1024 1024))))
	((> byte-count (* 1024 1024 1024))
	 (format stream "~,1f GB" (/ byte-count (* 1024 1024 1024))))
	((> byte-count (* 1024 1024))
	 (format stream "~,1f MB" (/ byte-count (* 1024 1024))))
	((> byte-count 1024)
	 (format stream "~,1f KB" (/ byte-count 1024)))
	(t
	 (princ byte-count stream))))

(lisp:clines "#include \"c-util.c\"")
(lisp:defentry integer->directory (lisp:int) (lisp:object "integer_to_dir"))
(lisp:defentry %file-size (lisp:string) (lisp:int "file_size"))
(lisp:defentry %chmod (lisp:string lisp:int) (lisp:int "chmod"))
(lisp:defentry %ensure-directories-exist (lisp:string) (lisp:int "ensure_dir"))

(defmethod file-size ((pathname string))
  (%file-size pathname))

(defmethod file-size ((pathname t))
  (%file-size (namestring pathname)))

(defun chmod (pathname mode)
  (%chmod (namestring pathname) mode))

(defun ensure-directories-exist (pathname)
  (prog1 pathname
    (unless (zerop (%ensure-directories-exist (namestring pathname)))
      (error "~s failed." 'ensure-directories-exist))))