# HG changeset patch # User Steve Losh # Date 1472601294 0 # Node ID 778814a3ff72633c3366c5b1ebdba9effa3fbd2f # Parent 56edfdd18674e897f0c88e5aa849d10d8fe55ce1 Wrap linenoise with CFFI diff -r 56edfdd18674 -r 778814a3ff72 package.lisp --- 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 diff -r 56edfdd18674 -r 778814a3ff72 sand.asd --- 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 diff -r 56edfdd18674 -r 778814a3ff72 src/ffi.lisp --- 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 " " :blue t))) + + +(setf *linenoise-completion-callback* 'test-compl) +(setf *linenoise-hints-callback* 'test-hint)