hash-functions.lisp

(in-package #:fwoar.lisputils)

#-sbcl
(defun empty-hash-table-like (hash-table)
  (make-hash-table :test (hash-table-test hash-table)
                   :size (hash-table-size hash-table)
                   :rehash-size (hash-table-rehash-size hash-table)
                   :rehash-threshold (hash-table-rehash-threshold hash-table)))
#+sbcl
(defun empty-hash-table-like (hash-table)
  (make-hash-table :test (hash-table-test hash-table)
                   :size (hash-table-size hash-table)
                   :rehash-size (hash-table-rehash-size hash-table)
                   :rehash-threshold (hash-table-rehash-threshold hash-table)
                   :hash-function (sb-impl::hash-table-hash-fun hash-table)))

;; (pick '("a" "b" "c")
;;         { "a": { "b" : { "c" : 3 })
;; =>> 3 t 3 "c"

;; (pick '("a" "b" "c")
;;         { "a": { "b" : 3 } })
;; =>> nil nil 3 "b"

;; (pick '("a" "b" "c")
;;         { "a": 3 })
;; =>> nil nil 3 "a"

;; (pick '("a" "b" "c")
;;         {})
;; =>> nil nil {} nil
(define-condition deprecation-warning (warning)
  ((%symbol :initarg :symbol :reader dw-symbol :initform (error "symbol required"))
   (%type :initarg :type :reader dw-type :initform (error "type required"))
   (%replacement :initarg :replacement :reader dw-replacement :initform (error "replacement required"))))

(defmethod print-object ((x deprecation-warning) stream)
  (if *print-escape*
      (call-next-method)
      (let ((symbol (dw-symbol x))              
            (replacement (dw-replacement x)))
        (format stream "~(~a~) named ~a:~a is deprecated, use ~a:~a instead"
                (dw-type x)
                (package-name (symbol-package symbol))
                symbol
                (package-name (symbol-package replacement))
                replacement))))

(defun pick (keys h-t &optional default)
  (warn 'deprecation-warning :symbol 'pick :type :function :replacement 'dive)
  (dive keys h-t default))

(defun dive (keys h-t &optional default)
  "(PICK KEYS H-T) => (values result found last-value last-key)
   result if all keys found, otherwise (or default nil)
   last-value the value associated with last-key or H-T if no key matches
   last-key the last key to match, or nil
   found-p nil if all keys didn't match otherwise truthy"
  (let ((result default)
        (found nil)
        (last-value h-t)
        (last-key nil)
	      (matched-keys 0)
        (key-count 0))
    (dolist (key keys)
      (incf key-count)
      (if (hash-table-p last-value)
	        (multiple-value-bind (next-value next-found)
              (gethash key last-value)
	          (setf found next-found)
	          (when next-found
	            (incf matched-keys)
	            (setf last-key key
		                last-value next-value)))
	        (setf found nil)))
    (when (= matched-keys key-count)
      (setf result last-value))
    (values result found last-value last-key)))

(define-condition pick-error (error)
  ((%key :initarg :key :reader key)
   (%value :initarg :value :reader value :initform nil)))

;; Stolen from sbcl . . . 
(defun read-evaluated-form (&optional (prompt-control nil promptp)
                            &rest prompt-args)
  (apply #'format *query-io*
         (if promptp prompt-control "~&Type a form to be evaluated: ")
         prompt-args)
  (finish-output *query-io*)
  (list (eval (read *query-io*))))

(defun pick/r (keys h-t &optional default)
  "Pick keys from h-t until fully traversed or no longer found.
   provide a restart for filling missing values. Raises pick-error
   if it tries to traverse a non-existent key or a non-hash-table
   value"

  (flet ((ensure-hash-table (v)
	   (unless (hash-table-p v)
	     (error 'type-error :expected-type 'hash-table :datum v))))
    (let ((cur-ht h-t))
      (dolist (key (butlast keys) (gethash (car (last keys)) cur-ht default))
	start
	(restart-case
	    (multiple-value-bind (value found) (gethash key cur-ht)
	      (cond ((null found) (error 'pick-error :key key))
		    ((hash-table-p value) (setf cur-ht value))
		    (t (error 'pick-error :key key :value value))))
	  (use-value (v)
	    :interactive read-evaluated-form
	    :report (lambda (stream) (format stream "Act as if the key was found"))
	    (ensure-hash-table v)
	    (setf cur-ht v))
	  (store-value (v)
	    :test (lambda (c) c (hash-table-p cur-ht))
	    :interactive read-evaluated-form
	    :report (lambda (stream) (format stream "Store a new value for ~S." key))
	    (ensure-hash-table v)
	    (setf (gethash key cur-ht) v)
	    (go start)))))))