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