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

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

Show me the code!

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)]))

In-depth example

Type-directed Objective-C extractors

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

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.

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

Appendices

objc-data-extractor.lisp

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

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

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

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>>

#+(and build sbcl)
(progn (sb-ext:disable-debugger)
       (sb-alien:alien-funcall
        (sb-alien:extern-alien "disable_lossage_handler"
                               (function sb-alien:void))))

Cheap and reliable Node.js hosting starts at $3/month, and $1/month static HTML hosting

fiddlerwoaroof / objc-lisp-bridge

Programming Languages

Labels

Projects that are alternatives of or similar to objc-lisp-bridge