git.fiddlerwoaroof.com
name mode size
..
Contents 040000
README.org
* Intro CCL and LispWorks and other implementations have their own bridges to the objective-c runtime. This project is an attempt to create a bridge that only uses CFFI so that arbitrary lisp implementations can produce native mac GUIs. In the long run, I hope to use this as the basis for a new mac-native backend for McClim: but we'll see if that ever happens. For the time being, though, this only works on CCL and (sort-of) on LispWorks: it works like 95% on SBCL, but there's some weird issue that's preventing the window from showing. I hae not tested the code on any other implementations, but doing so will require changing a couple places in objc-runtime.lisp to inform the code about the new lisp's ffi types. * Installing 1. clone fwoar.lisputils from https://github.com/fiddlerwoaroof/fwoar.lisputils and put it somewhere quicklisp can find it (e.g. ~/quicklisp/local-projects) 2. clone cffi from https://github.com/cffi/cffi and put it in the same place (on Big Sur, at least, I need changes that haven't made it to Quicklisp) 3. Install rsvg-convert: #+BEGIN_SRC sh :tangle no brew install librsvg #+END_SRC 4. build + run the demo: #+BEGIN_SRC sh :tangle no make mkapp CL=/path/to/cl open demo.app #+END_SRC * Show me the code! From demo-app.lisp: #+BEGIN_SRC lisp :tangle no (defun main () (trivial-main-thread:with-body-in-main-thread (:blocking t) [#@NSAutoReleasePool @(new)] [#@NSApplication @(sharedApplication)] [objc-runtime::ns-app @(setActivationPolicy:) :int 0] (objc-runtime::objc-register-class-pair (demo-app::make-app-delegate-class '("actionButton" "alertButton" "profitButton"))) (demo-app::load-nib "MainMenu") (let ((app-delegate [objc-runtime::ns-app @(delegate)])) (demo-app::make-button-delegate (value-for-key app-delegate "actionButton") (cffi:callback do-things-action)) (demo-app::make-button-delegate (value-for-key app-delegate "alertButton") (cffi:callback alert-action)) (demo-app::make-button-delegate (value-for-key app-delegate "profitButton") (cffi:callback profit-action))) [objc-runtime::ns-app @(activateIgnoringOtherApps:) :boolean t] [objc-runtime::ns-app @(run)])) #+END_SRC * In-depth example ** Type-directed Objective-C extractors #+name: extractor-framework #+begin_src lisp :tangle no :results no :comments both (defvar *objc-extractors* (list) "Functions called to extract specific data types") (defun extract-from-objc (obj) (objc-typecase obj (#@NSDate [[[[#@NSISO8601DateFormatter @(alloc)] @(init)] @(stringFromDate:) :pointer obj] @(UTF8String)]s) (#@NSString [obj @(UTF8String)]s) (#@NSNumber (parse-number:parse-number (objc-runtime::extract-nsstring [obj @(stringValue)]))) (#@NSArray (map-nsarray #'extract-from-objc obj)) (#@NSDictionary (fw.lu:alist-string-hash-table (pairlis (map-nsarray #'extract-from-objc [obj @(allKeys)]) (map-nsarray #'extract-from-objc [obj @(allValues)])))) (t (or (funcall-some (cdr (objc-pick-by-type obj *objc-extractors*)) obj) obj)))) (defmacro define-extractor (class (o) &body body) `(serapeum:eval-always (add-extractor ,class (lambda (,o) ,@body)) ,*objc-extractors*)) (defun clear-extractors () (setf *objc-extractors* ())) (serapeum:eval-always (defun add-extractor (class cb) (unless (member class *objc-extractors* :test 'cffi:pointer-eq :key #'car) (setf *objc-extractors* (merge 'list *objc-extractors* (list (cons class cb)) 'objc-subclass-p :key 'car))) ,*objc-extractors*)) #+end_src ** Reading List to Org-file converter The entry-point is fairly unremarkable: it delegates most of the work to other functions and disables the debugger so that this doesn't blow up when an error occurs in non-interactive mode. #+name: r-l-r-main #+begin_src lisp :tangle no :results no :noweb yes (defun main () <<disable-sbcl-debugger>> (make-org-file *standard-output* (get-readinglist-info (translate-plist (get-bookmark-filename))))) #+end_src This pair of functions builds an org file from data extracted from the Safari bookmark file. #+name: make-org-file #+begin_src lisp :tangle no :results no (defun make-org-file (s reading-list-info) (format s "~&* Safari Reading List~%") (serapeum:mapply (serapeum:partial 'make-org-entry s) reading-list-info)) (defun make-org-entry (s date title url preview tag) (format s "~&** ~a (~a) :~{~a:~}~% ~a~2% ~{~<~% ~1,80:;~a~> ~}~2%" title (local-time:format-timestring nil date :format local-time:+rfc3339-format/date-only+) (alexandria:ensure-list tag) url (serapeum:tokens preview))) #+end_src Here we extract the data from Bookmarks.plist using our polymorphic objc data extractor framework #+name: translate-plist #+begin_src lisp :tangle no :results no (defparameter *reading-list-location* "Library/Safari/Bookmarks.plist") (defun get-bookmark-filename () (uiop:native-namestring (merge-pathnames *reading-list-location* (truename "~/")))) (defun translate-plist (fn) (objc-runtime.data-extractors:extract-from-objc (objc-runtime.data-extractors:get-plist fn))) #+end_src #+name: translate-data #+begin_src lisp :tangle no :results no (defun get-readinglist-info (bookmarks) (sort (mapcar 'extract-link-info (gethash "Children" (car (select-child bookmarks "com.apple.ReadingList")))) 'local-time:timestamp> :key 'car)) (defun extract-link-info (link) (list (local-time:parse-rfc3339-timestring (or (fw.lu:pick '("ReadingList" "DateAdded") link) (fw.lu:pick '("ReadingList" "DateLastViewed") link) (fw.lu:pick '("ReadingListNonSync" "DateLastFetched") link) (local-time:now))) (fw.lu:pick '("URIDictionary" "title") link) (fw.lu:pick '("URLString") link) (plump:decode-entities (coerce (fw.lu:pick '("ReadingList" "PreviewText") link) 'simple-string) t) (fw.lu:may (slugify (fw.lu:pick '("ReadingListNonSync" "siteName") link))))) #+end_src ** Appendices *** objc-data-extractor.lisp #+begin_src lisp :tangle objc-data-extractors.lisp :noweb yes :comments both (defpackage :objc-runtime.data-extractors (:use :cl ) (:export #:extract-from-objc #:define-extractor #:clear-extractors #:add-extractor #:get-plist)) (in-package :objc-runtime.data-extractors) (named-readtables:in-readtable :objc-readtable) (defun get-plist (file) [#@NSDictionary @(dictionaryWithContentsOfFile:) :pointer (objc-runtime::make-nsstring file)]) (defun objc-subclass-p (sub super) (unless (or (cffi:null-pointer-p sub) (cffi:null-pointer-p super)) (or (eql sub super) (= [sub @(isSubclassOfClass:) :pointer [super @(class)]]# 1)))) (defun order-objc-classes (classes &rest r &key key) (declare (ignore key)) (apply 'stable-sort (copy-seq classes) 'objc-subclass-p r)) (defun objc-isa (obj class) (unless (or (cffi:null-pointer-p obj) (cffi:null-pointer-p class)) (= [obj @(isKindOfClass:) :pointer class]# 1))) (defun objc-pick-by-type (obj pairs) (assoc obj (order-objc-classes pairs :key 'car) :test 'objc-isa)) (serapeum:eval-always (defun make-cases (cases obj) (mapcar (serapeum:op `(if (objc-isa ,obj ,(car _1)) (progn ,@(cdr _1)))) cases))) (defmacro objc-typecase (form &body ((case-type &body case-handler) &rest cases)) (alexandria:once-only (form) (let* ((initial-cases `((,case-type ,@case-handler) ,@(butlast cases))) (cases (fw.lu:rollup-list (make-cases initial-cases form) (if (eql t (caar (last cases))) `((progn ,@(cdar (last cases)))) (make-cases (last cases) form))))) cases))) (defun map-nsarray (fn arr) (unless (and (cffi:pointerp arr) (objc-isa arr #@NSArray)) (error "must provide a NSArray pointer")) (loop for x below [arr @(count)]# collect (funcall fn [arr @(objectAtIndex:) :int x]))) (defun nsarray-contents (arr) (unless (and (cffi:pointerp arr) (objc-isa arr #@NSArray)) (error "must provide a NSArray pointer")) (dotimes (n [arr @(count)]#) (let ((obj [arr @(objectAtIndex:) :int n ])) (objc-typecase obj (#@NSString (format t "~&string~%")) (#@NSArray (format t "~&array~%")) (#@NSDictionary (format t "~&dictionary~%")) (t (format t "~&other... ~s~%" (objc-runtime::objc-class-get-name (objc-runtime::object-get-class obj)))))))) (defmacro funcall-some (fun &rest args) (alexandria:once-only (fun) `(if ,fun (funcall ,fun ,@args)))) <<extractor-framework>> #+end_src *** build-reading-list-reader.sh #+begin_src sh :tangle build-reading-list-reader.sh #!/usr/bin/env bash set -eu -x -o pipefail cd "$(dirname $0)" mkdir -p dist pushd dist rm -rf fwoar.lisputils git clone https://github.com/fiddlerwoaroof/fwoar.lisputils.git popd export CL_SOURCE_REGISTRY="$PWD/dist//" sbcl --no-userinit \ --load ~/quicklisp/setup.lisp \ --load build.lisp #+end_src *** build.lisp #+begin_src lisp :mkdirp yes :results no :noweb yes :tangle build.lisp (eval-when (:compile-toplevel :load-toplevel :execute) (setf *default-pathname-defaults* (truename "~/git_repos/objc-lisp-bridge/")) (load (compile-file "objc-runtime.asd"))) (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload '(:objc-runtime :yason :plump :cl-ppcre))) (load "reading-list-reader.lisp") (eval-when (:compile-toplevel :load-toplevel :execute) (sb-ext:save-lisp-and-die "reading-list2org" :toplevel (intern "MAIN" "READING-LIST-READER") :executable t)) #+end_src *** reading-list-reader.lisp #+begin_src lisp :mkdirp yes :results no :noweb yes :tangle reading-list-reader.lisp (defpackage :reading-list-reader (:use :cl ) (:export )) (in-package :reading-list-reader) (serapeum:eval-always (named-readtables:in-readtable :objc-readtable)) (defun slugify (s) (cl-ppcre:regex-replace-all "\\s+" (string-downcase s) "_")) (defun select-child (d title) (flet ((get-title (h) (equal (gethash "Title" h) title))) (fw.lu:let-each (:be *) (gethash "Children" d) (remove-if-not #'get-title *)))) <<translate-plist>> <<make-org-file>> <<translate-data>> <<r-l-r-main>> #+end_src #+name: disable-sbcl-debugger #+begin_src lisp :tangle no ,#+(and build sbcl) (progn (sb-ext:disable-debugger) (sb-alien:alien-funcall (sb-alien:extern-alien "disable_lossage_handler" (function sb-alien:void)))) #+end_src # Local Variables: # fill-column: 120 : # End: