@@ -1,16 +1,6 @@

 ;;;; fwoar-lisputils.asd

 (in-package :asdf-user)

-(defsystem #:fwoar-lisputils/string-utils

-  :description "A binary parser"

-  :author "fiddlerwoaroof <fiddlerwoaroof@gmail.com"

-  :license "MIT"

-  :depends-on (#:should-test)

-  :components ((:file "string-utils/package")

-               (:file "string-utils/string-utils" :depends-on ("string-utils/package"))

-               #-lispworks

-               (:file "string-utils/test" :depends-on ("string-utils/string-utils"))))

-

 (asdf:defsystem #:fwoar-lisputils

   :description "Some utilities common to other libraries I'm writing"

   :author "fiddlerwoaroof <fiddlerwoaroof@gmail.com"

@@ -40,7 +30,31 @@

                (:file "non-lispworks")

                #-lispworks

                (:file "patmatch")

-               (:file "glambda")))

+               (:file "glambda")

+               (:file "misc")))

+

+(defsystem #:fwoar-lisputils/string-utils

+  :description "A string splitter"

+  :author "fiddlerwoaroof <fiddlerwoaroof@gmail.com"

+  :license "MIT"

+  :depends-on (#:should-test)

+  :components ((:file "string-utils/package")

+               (:file "string-utils/string-utils" :depends-on ("string-utils/package"))

+               #-lispworks

+               (:file "string-utils/test" :depends-on ("string-utils/string-utils"))))

+

+(asdf:defsystem #:fwoar-lisputils/swank-utils

+  :description "Utilities for use with swank"

+  :author "fiddlerwoaroof <fiddlerwoaroof@gmail.com"

+  :license "MIT"

+  :serial t

+  :perform (test-op (o s)

+                    (funcall (intern "TEST" :should-test)

+                             :package :fwoar.string-utils))

+  :depends-on (#:fwoar-lisputils

+               #:yason

+               #:swank)

+  :components ((:file "swank-utils")))

 (defsystem #:fwoar-lisputils/bin-parser

   :description "A binary parser"

@@ -15,26 +15,45 @@

 ;; (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))

+	      (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)))

+	        (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)))

@@ -32,7 +32,8 @@

            #:may #:defun-ct

            #:define-cluser-entrypoint

            #:new

-           #:make-constructor)) 

+           #:make-constructor

+           #:dive)) 

 (defpackage :fwoar.lisputils.shortcuts

new file mode 100644

@@ -0,0 +1,19 @@

+(defpackage :fwoar.swank-utils

+  #+fw.dev

+  (:nicknames fw.su)

+  (:use :cl )

+  (:export

+   #:log-json))

+(in-package :fwoar.swank-utils)

+

+(defvar *target-identifier* (alexandria:make-keyword (gensym "JSON")))

+(defun log-json (obj &optional (indent t) (target-identifier *target-identifier*))

+  (let* ((buffer-stream (swank-buffer-streams:make-buffer-output-stream target-identifier))

+         (stream (yason:make-json-output-stream buffer-stream :indent indent)))

+    (unwind-protect (progn (fresh-line buffer-stream)

+                           (values (yason:encode obj stream)

+                                   target-identifier))

+      (terpri buffer-stream)

+      (finish-output stream)

+      (finish-output buffer-stream)

+      (close stream))))