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