@@ -31,3 +31,4 @@ NSRect-Expose

 .*.sw?

 venv

 /reading-list2org

+/dist/

new file mode 100644

@@ -0,0 +1,15 @@

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

new file mode 100644

@@ -0,0 +1,14 @@

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

new file mode 100644

@@ -0,0 +1,112 @@

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

+

+(defvar *objc-extractors* (list)

+  "Functions called to extract specific data types")

+

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

+

+(defmacro define-extractor (class (o) &body body)

+  `(serapeum:eval-always

+     (add-extractor ,class

+                    (lambda (,o)

+                      ,@body))

+     *objc-extractors*))

+

+(defun clear-extractors ()

+  (setf *objc-extractors* ()))

+

+(defmacro funcall-some (fun &rest args)

+  (alexandria:once-only (fun)

+    `(if ,fun

+         (funcall ,fun ,@args))))

+

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

@@ -18,4 +18,5 @@

                (:cffi-grovel-file "objc-runtime-types" :depends-on ("package"))

                (:file "readtable" :depends-on ("package"))

                (:file "gcd" :depends-on ("objc-runtime"))

-               (:file "objc-runtime" :depends-on ("package" "readtable" "objc-runtime-types"))))

+               (:file "objc-runtime" :depends-on ("package" "readtable" "objc-runtime-types"))

+               (:file "objc-data-extractors" :depends-on ("objc-runtime" "readtable"))))

@@ -27,3 +27,12 @@

    #:add-pointer-ivar

    #:objc-msg-send-int

    #:objc-msg-send-string))

+

+(defpackage :objc-runtime.data-extractors

+  (:use :cl )

+  (:export

+   #:extract-from-objc

+   #:define-extractor

+   #:clear-extractors

+   #:add-extractor

+   #:get-plist))

@@ -1,100 +1,33 @@

-#+build

-(eval-when (:compile-toplevel :load-toplevel :execute)

-  (setf *default-pathname-defaults* (truename "~/git_repos/objc-lisp-bridge/"))

-  (load (compile-file "objc-runtime.asd")))

-

-#+build

-(eval-when (:compile-toplevel :load-toplevel :execute)

-  (ql:quickload '(:objc-runtime :yason :plump :cl-ppcre)))

-

 (defpackage :reading-list-reader

   (:use :cl )

   (:export ))

 (in-package :reading-list-reader)

 (serapeum:eval-always

- (named-readtables:in-readtable :objc-readtable))

-

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

-

-(defun get-plist (file)

-  [#@NSDictionary @(dictionaryWithContentsOfFile:)

-                  :pointer (objc-runtime::make-nsstring file)])

-

-

-(defun objc-isa (obj class)

-  (unless (or (cffi:null-pointer-p obj)

-              (cffi:null-pointer-p class))

-    (= [obj @(isKindOfClass:) :pointer class]#

-       1)))

-

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

+  (named-readtables:in-readtable :objc-readtable))

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

-

-(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 (format *error-output* "~&other... ~s~%" (objc-runtime::objc-class-get-name

-                                                 (objc-runtime::object-get-class obj))))))

+(defun main ()

+  #+(and build sbcl)

+  (progn (sb-ext:disable-debugger)

+         (sb-alien:alien-funcall

+          (sb-alien:extern-alien "disable_lossage_handler"

+                                 (function sb-alien:void))))

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

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

-(defun extract-nsdictionary (nsdict)

-  (yason:with-output (*standard-output* :indent t)

-    (maphash 'yason:encode-object-element

-             (extract-from-objc nsdict))))

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

+(defun get-bookmark-filename ()

+  (merge-pathnames *reading-list-location*

+                   (truename "~/")))

-(defun select-child (d title)

-  (remove-if-not (serapeum:op

-                   (equal (gethash "Title" _)

-                          title))

-                 (gethash "Children" d)))

+(defun translate-plist (fn)

+  (objc-runtime.data-extractors:extract-from-objc

+   (objc-runtime.data-extractors:get-plist fn)))

-(defun slugify (s)

-  (when s

-    (cl-ppcre:regex-replace-all "\\s+" (string-downcase s) "_")))

+(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~> ~}~%"

@@ -104,29 +37,37 @@

 (defun get-readinglist-info (bookmarks)

   (mapcar (serapeum:juxt

-           (fw.lu:op (fw.lu:pick '("URIDictionary" "title") _))

-           (fw.lu:op (fw.lu:pick '("URLString") _))

-           (fw.lu:op (plump:decode-entities (coerce (fw.lu:pick '("ReadingList" "PreviewText") _)

-                                                    'simple-string)

-                                            t))

-           (fw.lu:op (slugify (fw.lu:pick '("ReadingListNonSync" "siteName") _))))

+           (fw.lu:op

+             (fw.lu:pick '("URIDictionary" "title")

+                         _))

+           (fw.lu:op

+             (fw.lu:pick '("URLString")

+                         _))

+           (fw.lu:op

+             (plump:decode-entities

+              (coerce (fw.lu:pick '("ReadingList" "PreviewText")

+                                  _)

+                      'simple-string)

+              t))

+           (fw.lu:op

+             (fw.lu:may

+               (slugify

+                (fw.lu:pick '("ReadingListNonSync" "siteName")

+                            _)))))

           (gethash "Children"

                    (car

-                    (select-child bookmarks "com.apple.ReadingList")))))

-

+                    (select-child bookmarks

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

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

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

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

-                   (get-readinglist-info bookmarks)))

-

-(defun main ()

-  #+(and build sbcl)

-  (progn (sb-ext:disable-debugger)

-         (sb-alien:alien-funcall

-          (sb-alien:extern-alien "disable_lossage_handler" (function sb-alien:void))))

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

-                 (extract-from-objc (get-plist (uiop:unix-namestring (truename *reading-list-location*))))))

+(defun slugify (s)

+  (cl-ppcre:regex-replace-all "\\s+"

+                              (string-downcase s)

+                              "_"))

-#+build

-(sb-ext:save-lisp-and-die "reading-list2org" :toplevel 'main :executable t)

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