@@ -61,3 +61,268 @@ From demo-app.lisp:

       [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

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

+

+ #+name: r-l-r-main

+ #+begin_src lisp :tangle no :results no :noweb yes

+   (defun main ()

+     <<disable-sbcl-debugger>>

+     (make-org-file *standard-output*

+                    (translate-plist (get-bookmark-filename))))

+ #+end_src

+

+ #+name: translate-plist

+ #+begin_src lisp :tangle no :results no

+   (defparameter *reading-list-location* "Library/Safari/Bookmarks.plist")

+   (defun get-bookmark-filename ()

+     (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: make-org-file

+ #+begin_src lisp :tangle no :results no

+   (defun make-org-file (s bookmarks)

+     (format s "~&* Safari Reading List~%")

+     (serapeum:mapply (serapeum:partial 'make-org-entry s)

+                      (get-readinglist-info bookmarks)))

+   (defun make-org-entry (s title url preview tag)

+     (format s "~&** ~a :~{~a:~}~% ~a~2% ~{~<~% ~1,80:;~a~> ~}~%"

+             title (alexandria:ensure-list tag)

+             url

+             (serapeum:tokens preview)))

+ #+end_src

+

+ #+name: translate-data

+ #+begin_src lisp :tangle no :results no

+   (defun get-readinglist-info (bookmarks)

+     (mapcar 'extract-link-info

+             (gethash "Children"

+                      (car

+                       (select-child bookmarks

+                                     "com.apple.ReadingList")))))

+

+   (defun extract-link-info (link)

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

+

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

+ #+end_src

+

+** Appendices

+  

+*** objc-data-extractor.lisp

+

+ #+begin_src lisp :tangle untangled/objc-data-extractors.lisp :noweb yes

+   (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 untangled/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 untangled/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 untangled/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))

+

+   <<r-l-r-main>>

+   <<translage-plist>>

+   <<make-org-file>>

+   <<translate-data>>

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