--- a/package.lisp Tue Aug 30 12:04:52 2016 +0000
+++ b/package.lisp Tue Aug 30 23:54:54 2016 +0000
@@ -129,11 +129,11 @@
#+sbcl
(defpackage #:sand.ffi
(:use
- #:sb-alien
#:cl
#:cl-arrows
#:losh
#:iterate
+ #:cffi
#:sand.quickutils
#:sand.utils)
(:export--- a/sand.asd Tue Aug 30 12:04:52 2016 +0000
+++ b/sand.asd Tue Aug 30 23:54:54 2016 +0000
@@ -24,6 +24,7 @@
#:clss
#:cl-algebraic-data-type
#:rs-colors
+ #:cffi
)
:serial t--- a/src/ffi.lisp Tue Aug 30 12:04:52 2016 +0000
+++ b/src/ffi.lisp Tue Aug 30 23:54:54 2016 +0000
@@ -1,45 +1,130 @@
(in-package #:sand.ffi)
-(define-alien-routine ("strlen" c-str-len) size-t
- (s c-string :in))
-(define-alien-routine ("hypot" hypotenuse) double
- (x double :in)
- (y double :in))
+;;;; Library ------------------------------------------------------------------
+(define-foreign-library linenoise
+ (:darwin "~/src/linenoise/linenoise.dylib"))
+
+(use-foreign-library linenoise)
+
-(define-alien-routine ("strchr" string-char) c-string
- (s c-string)
- (c int))
+;;;; Simple Functions ---------------------------------------------------------
+(defcfun ("linenoiseClearScreen" linenoise-clear-screen) :void)
+
+(defcfun ("linenoiseSetMultiLine" %linenoise-set-multi-line) :void
+ (ml :int))
-(declaim (inline is-upper))
-(define-alien-routine ("isupper" is-upper) int
- (ch int))
+(defun linenoise-set-multi-line (flag)
+ (%linenoise-set-multi-line (convert-to-foreign flag :boolean)))
+
+(defcfun ("linenoiseHistorySetMaxLen" linenoise-history-set-max-length) :int
+ (len :int))
-(defun uppercasep (character)
- (not (zerop (is-upper (char-code character)))))
+(defcfun ("linenoiseHistorySave" linenoise-history-save) :int
+ (filename :string))
+
+(defcfun ("linenoiseHistoryLoad" linenoise-history-load) :int
+ (filename :string))
-(c-str-len "Hello!")
-(load-shared-object "~/src/linenoise/linenoise.dylib")
+(defcfun ("linenoiseHistoryAdd" linenoise-history-add) :int
+ (line :string))
-(define-alien-routine linenoise c-string
- (prompt c-string))
+(defcfun ("linenoiseFree" linenoise-free) :void
+ (pointer :pointer))
-(define-alien-routine
- ("linenoiseHistorySetMaxLen" linenoise-history-set-max-len)
- int
- (max-length int))
+(defun linenoise (prompt &key (add-to-history t))
+ (let ((ptr (foreign-funcall "linenoise" :string prompt (:pointer :char))))
+ (unwind-protect
+ (let ((result (convert-from-foreign ptr :string)))
+ (when add-to-history
+ (linenoise-history-add result))
+ result)
+ (linenoise-free ptr))))
-(define-alien-routine ("linenoiseHistoryAdd" linenoise-history-add) int
- (string c-string))
-(define-alien-routine ("linenoiseClearScreen" linenoise-clear-screen) void)
+;;;; Completion Callbacks -----------------------------------------------------
+(defparameter *linenoise-completion-callback* nil)
+(defcfun ("linenoiseAddCompletion" linenoise-add-completion) :void
+ (lc :pointer)
+ (str :string))
-; (linenoise-history-set-max-len 10)
-; (linenoise-history-add "Alice")
-; (linenoise-history-add "Bob")
-; (iterate (for i :from 0 :to 20)
-; (linenoise-history-add (format nil "history entry ~d" i)))
-; (linenoise "? ")
+(defcfun ("linenoiseSetCompletionCallback" linenoise-set-completion-callback)
+ :void
+ (callback :pointer))
+
+(defcallback linenoise-completion-callback :void
+ ((prefix (:pointer :char))
+ (lc :pointer))
+ (when *linenoise-completion-callback*
+ (mapc (curry #'linenoise-add-completion lc)
+ (funcall *linenoise-completion-callback*
+ (convert-from-foreign prefix :string))))
+ (values))
+
+(linenoise-set-completion-callback (callback linenoise-completion-callback))
+
+
+;;;; Hints Callbacks ----------------------------------------------------------
+(defparameter *linenoise-hints-callback* nil)
+
+(defcfun ("linenoiseSetHintsCallback" linenoise-set-hints-callback) :void
+ (callback :pointer))
+
+(defcfun ("linenoiseSetFreeHintsCallback" linenoise-set-free-hints-callback)
+ :void
+ (callback :pointer))
+(defcallback linenoise-hints-callback :string
+ ((prefix (:pointer :char))
+ (color (:pointer :int))
+ (bold (:pointer :int)))
+ (if *linenoise-hints-callback*
+ (multiple-value-bind (hint hint-color hint-bold)
+ (funcall *linenoise-hints-callback*
+ (convert-from-foreign prefix :string))
+ (if hint
+ (prog1
+ (foreign-string-alloc hint)
+ (when hint-color
+ (setf (mem-ref color :int) (ecase hint-color
+ (:red 31)
+ (:green 32)
+ (:yellow 33)
+ (:blue 34)
+ (:magenta 35)
+ (:cyan 36)
+ (:white 37))))
+ (when hint-bold
+ (setf (mem-ref bold :boolean) hint-bold)))
+ (null-pointer)))
+ (null-pointer)))
+
+(defcallback linenoise-free-hints-callback :void
+ ((hint-string :pointer))
+ (foreign-string-free hint-string))
+
+(linenoise-set-hints-callback (callback linenoise-hints-callback))
+(linenoise-set-free-hints-callback (callback linenoise-free-hints-callback))
+
+
+;;;; Scratch ------------------------------------------------------------------
+(defun test-compl (prefix)
+ (let ((result nil))
+ (when (not (string= "" prefix))
+ (when (char= #\f (aref prefix 0))
+ (pushnew "foo" result)
+ (pushnew "frob" result)
+ (pushnew "flip" result))
+ (when (char= #\b (aref prefix 0))
+ (pushnew "bar" result)))
+ result))
+
+(defun test-hint (prefix)
+ (when (string= "cp " prefix)
+ (values "<source> <dest>" :blue t)))
+
+
+(setf *linenoise-completion-callback* 'test-compl)
+(setf *linenoise-hints-callback* 'test-hint)