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.
- clone fwoar.lisputils from https://github.com/fiddlerwoaroof/fwoar.lisputils and put it somewhere quicklisp can find it (e.g. ~/quicklisp/local-projects)
- 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)
- Install rsvg-convert:
brew install librsvg - build + run the demo:
make mkapp CL=/path/to/cl open demo.app
From demo-app.lisp:
(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)]))
(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*))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.
(defun main ()
<<disable-sbcl-debugger>>
(make-org-file *standard-output*
(get-readinglist-info
(translate-plist
(get-bookmark-filename)))))This pair of functions builds an org file from data extracted from the Safari bookmark file.
(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)))Here we extract the data from Bookmarks.plist using our polymorphic objc data extractor framework
(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)))(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)))))(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>>#!/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(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))(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>>#+(and build sbcl)
(progn (sb-ext:disable-debugger)
(sb-alien:alien-funcall
(sb-alien:extern-alien "disable_lossage_handler"
(function sb-alien:void))))