├── demo.app.template
└── Contents
│ ├── PkgInfo
│ └── Info.plist
├── convert.sh
├── window.lisp
├── .dir-locals.el
├── .gitignore
├── save.lisp
├── Makefile.minimal
├── gcd.lisp
├── stack-view.lisp
├── manipulators.lisp
├── mop-test.lisp
├── objc-runtime-types.lisp
├── package.lisp
├── Makefile
├── objc-runtime.asd
├── notification.lisp
├── clog-dnc-player.lisp
├── reading-list-reader.lisp
├── readtable.lisp
├── objc-data-extractors.lisp
├── clim-objc-browser.lisp
├── bundle-utils.lisp
├── scripting-bridge.lisp
├── demo-app.svg
├── README.org
├── objc-runtime.lisp
├── demo-app.lisp
└── MainMenu.xib
/demo.app.template/Contents/PkgInfo:
--------------------------------------------------------------------------------
1 | APPLMyAp
--------------------------------------------------------------------------------
/convert.sh:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env zsh
2 |
3 | DISPLAY=''
4 |
5 | rsvg-convert -w "$2" -h "$2" "$1" > "$3"
6 |
--------------------------------------------------------------------------------
/window.lisp:
--------------------------------------------------------------------------------
1 | (defpackage :objc-runtime.window
2 | (:use :cl)
3 | (:export :with-window))
4 | (in-package :objc-runtime.window)
5 |
--------------------------------------------------------------------------------
/.dir-locals.el:
--------------------------------------------------------------------------------
1 | ;;; Directory Local Variables
2 | ;;; For more information see (info "(emacs) Directory Variables")
3 |
4 | ((lisp-mode . ((fwoar::*package-prefix* . "objc"))))
5 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | *.*f*sl
2 | foo*
3 | *tmp*
4 | ns-test
5 | *.dylib
6 | *~
7 | *grovel*
8 | a.out
9 | GPATH
10 | GRTAGS
11 | GTAGS
12 | .*.dSYM
13 | *.dSYM
14 | *~
15 | *.o
16 | .[#]*[#]
17 | [#]*
18 | *.old
19 | nsrect-expose.c
20 | test.c
21 | .[#]*
22 | demo-app
23 | demo.app
24 | *.framework
25 | .DS_Store
26 | *.iconset
27 | *.png
28 | *.icns
29 | NSRect-Expose
30 | *.nib
31 | .*.sw?
32 | venv
33 | /reading-list2org
34 | /dist/
35 | /safari2org
36 | /safari2org-beta
37 |
--------------------------------------------------------------------------------
/save.lisp:
--------------------------------------------------------------------------------
1 | (eval-when (:compile-toplevel :load-toplevel :execute) (load (compile-file "objc-runtime.asd")))
2 | (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :objc-runtime))
3 | (eval-when (:compile-toplevel :load-toplevel :execute) (load (compile-file "demo-app.lisp")))
4 |
5 | #+sbcl
6 | (sb-ext:save-lisp-and-die "demo-app" :toplevel 'demo-app::main :executable t)
7 | #+ccl
8 | (ccl:save-application "demo-app" :toplevel-function 'demo-app::main :prepend-kernel t)
9 |
--------------------------------------------------------------------------------
/demo.app.template/Contents/Info.plist:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 | CFBundleExecutable
6 | demo-app
7 | CFBundleIdentifier
8 | com.fwoar.demo-app
9 | CFBundleIconFile
10 | demo-app
11 | CFBundleDisplayName
12 | Demo App
13 |
14 |
15 |
--------------------------------------------------------------------------------
/Makefile.minimal:
--------------------------------------------------------------------------------
1 | CCL=ccl
2 |
3 | dylib: nsrect-expose.m
4 | clang -arch x86_64 -arch arm64 \
5 | -shared \
6 | -framework Cocoa \
7 | nsrect-expose.m \
8 | -o libnsrect-expose.dylib
9 | demo-app: dylib
10 | $(CCL) --load ~/quicklisp/setup.lisp \
11 | --eval '(load (compile-file "objc-runtime.asd"))' \
12 | --eval '(ql:quickload :objc-runtime)' \
13 | --eval '(load (compile-file "demo-app.lisp"))' \
14 | --eval '(ccl:save-application "demo-app" :toplevel-function '"'"'demo-app::main :prepend-kernel t)'
15 | mkapp: dylib demo-app
16 | rm -rf demo.app
17 | cp -R demo.app.template demo.app
18 | mkdir -p demo.app/Contents/{Resources,MacOS}
19 | ibtool --compile demo.app/Contents/Resources/MainMenu.nib MainMenu.xib
20 | cp demo-app demo.app/Contents/MacOS
21 |
--------------------------------------------------------------------------------
/gcd.lisp:
--------------------------------------------------------------------------------
1 | (defpackage :objc-runtime.gcd
2 | (:use :cl :cffi)
3 | (:export ))
4 | (in-package :objc-runtime.gcd)
5 |
6 | (serapeum:eval-always
7 | (pushnew #p"/usr/lib/system/"
8 | cffi:*foreign-library-directories*
9 | :test 'equal))
10 |
11 | (serapeum:eval-always
12 | (define-foreign-library dispatch
13 | (:darwin "libdispatch.dylib")))
14 |
15 | (defcfun
16 | (get-global-queue "dispatch_get_global_queue" :library dispatch)
17 | :pointer
18 | (id :long)
19 | (flags :unsigned-long))
20 |
21 | (defun get-main-queue ()
22 | (cffi:foreign-symbol-pointer "_dispatch_main_q"))
23 |
24 | (defcfun (dispatch-async "dispatch_async_f" :library dispatch)
25 | :pointer
26 | (queue :pointer)
27 | (context :pointer)
28 | (block :pointer))
29 |
30 | (defmacro def-gcd-callback (name (context-sym) &body body)
31 | `(progn
32 | (defcallback ,name :void ((,context-sym :pointer))
33 | (declare (ignorable ,context-sym))
34 | ,@body)
35 | (define-symbol-macro ,name (callback ,name))))
36 |
--------------------------------------------------------------------------------
/stack-view.lisp:
--------------------------------------------------------------------------------
1 | (defpackage :fwoar.stack-view
2 | (:use :cl )
3 | (:export ))
4 | (in-package :fwoar.stack-view)
5 | (named-readtables:in-readtable :objc-readtable)
6 |
7 | (cffi:defcstruct ns-edge-insets
8 | (top :double)
9 | (left :double)
10 | (bottom :double)
11 | (right :double))
12 |
13 | (cffi:defcfun (make-edge-insets "NSEdgeInsetsMake")
14 | (:struct ns-edge-insets)
15 | (top :double)
16 | (left :double)
17 | (bottom :double)
18 | (right :double))
19 |
20 | (cffi:defcfun (%set-edge-insets "objc_msgSend")
21 | :void
22 | (cls objc-runtime::o-class)
23 | (sel objc-runtime::o-selector)
24 | (value (:struct ns-edge-insets)))
25 |
26 | (defun set-edge-insets (stack-view top right bottom left)
27 | (%set-edge-insets stack-view
28 | @(setEdgeInsets:)
29 | (list 'top (coerce top 'double-float)
30 | 'left (coerce left 'double-float)
31 | 'bottom (coerce bottom 'double-float)
32 | 'right (coerce right 'double-float))))
33 |
34 | (defun add-view-to-stack (stack-view child)
35 | [stack-view @(addView:inGravity:) :pointer child :int 1])
36 |
--------------------------------------------------------------------------------
/manipulators.lisp:
--------------------------------------------------------------------------------
1 | (cl:in-package :objc.manipulators)
2 | (named-readtables:in-readtable :objc-readtable)
3 |
4 | (serapeum:eval-always
5 | (let (*it*)
6 | (declare (special *it*))
7 | (defgeneric sel (type sel)
8 | (:method :around (type sel)
9 | (lambda (*it*)
10 | (declare (special *it*))
11 | (call-next-method)))
12 |
13 | (:method (type sel)
14 | [*it* sel])
15 |
16 | (:method ((type (eql :int)) sel)
17 | [*it* sel]#)
18 |
19 | (:method ((type (eql :string)) sel)
20 | [*it* sel]s)
21 |
22 | (:method ((type (eql :nsstring)) sel)
23 | [*it* sel]@))))
24 |
25 | (defun-ct ext ()
26 | (lambda (it)
27 | (objc-runtime.data-extractors:extract-from-objc it)))
28 |
29 | (defun-ct <> (&rest funs)
30 | (apply #'alexandria:compose funs))
31 |
32 | (defun-ct :add-index :"
7 | :license "MIT"
8 | :depends-on (#:alexandria
9 | #:cffi
10 | #:cffi-libffi
11 | #:data-lens
12 | #:fset
13 | #:fwoar-lisputils
14 | #:serapeum
15 | #:trivial-features
16 | #:trivial-main-thread
17 | #:uiop)
18 | :defsystem-depends-on (#:cffi-grovel
19 | #:cffi-libffi)
20 | :components ((:file "package")
21 | (:cffi-grovel-file "objc-runtime-types" :depends-on ("package" "readtable"))
22 | (:file "bundle-utils" :depends-on ("package" "readtable"))
23 | (:file "readtable" :depends-on ("package"))
24 | (:file "gcd" :depends-on ("objc-runtime"))
25 | (:file "objc-runtime" :depends-on ("package" "readtable" "objc-runtime-types"))
26 | (:file "objc-data-extractors" :depends-on ("objc-runtime" "readtable"))
27 | (:file "manipulators" :depends-on ("objc-data-extractors" "readtable" "objc-runtime"))))
28 |
29 | (defsystem :objc-runtime/scripting-bridge
30 | :description ""
31 | :author "Ed L "
32 | :license "MIT"
33 | :depends-on (:objc-runtime
34 | :data-lens)
35 | :components ((:file "scripting-bridge")))
36 |
37 | (defsystem :objc-runtime/notifications
38 | :description ""
39 | :author "Ed L "
40 | :license "MIT"
41 | :depends-on (:objc-runtime
42 | :trivial-main-thread
43 | (:require :sb-concurrency))
44 | :components ((:file "notification")))
45 |
46 | (defsystem :objc-runtime/clim-objc-browser
47 | :description ""
48 | :author "Ed L "
49 | :license "MIT"
50 | :depends-on (:objc-runtime
51 | :serapeum
52 | :alexandria
53 | :mcclim)
54 | :components ((:file "clim-objc-browser")))
55 |
--------------------------------------------------------------------------------
/notification.lisp:
--------------------------------------------------------------------------------
1 | (defpackage :objc.notification
2 | (:use :cl )
3 | (:export
4 | #:main-loop-ticker
5 | #:dnc
6 | #:observe-notifications
7 | #:*mailbox*
8 | #:setup-notifications))
9 | (in-package :objc.notification)
10 | (serapeum:eval-always
11 | (named-readtables:in-readtable :objc-readtable))
12 |
13 | (defun main-loop-ticker ()
14 | (let ((main-run-loop [#@NSRunLoop @(mainRunLoop)]))
15 | (loop do
16 | (sleep 0.1)
17 | (trivial-main-thread:with-body-in-main-thread (:blocking t)
18 | (objc-runtime::tick-ns-runloop main-run-loop
19 | 0.1)))))
20 |
21 | (defun dnc ()
22 | [#@NSDistributedNotificationCenter
23 | @(defaultCenter)])
24 |
25 | (defvar *mailbox*)
26 | (cffi:defcallback handle-notification :void
27 | ((_ :pointer) (__ :pointer) (notification :pointer))
28 | (declare (ignore _ __))
29 | (sb-concurrency:send-message
30 | *mailbox*
31 | (objc-runtime.data-extractors:extract-from-objc
32 | [notification @(userInfo)])))
33 |
34 | (defvar *notification-handler*)
35 | (defun setup-notifications ()
36 | (if (boundp '*notification-handler*)
37 | *notification-handler*
38 | (let ((delegate-class
39 | (objc-runtime::objc-allocate-class-pair
40 | #@NSObject
41 | (format nil "FWNotificationHandler~a"
42 | (gensym))
43 | 0)))
44 | (objc-runtime::class-add-method
45 | delegate-class
46 | @(handle-notification:)
47 | (cffi:callback handle-notification)
48 | "v@:@")
49 | (setf *mailbox*
50 | (sb-concurrency:make-mailbox)
51 |
52 | *notification-handler*
53 | [[delegate-class @(alloc)] @(init)]))))
54 |
55 | (define-condition notifications-not-initialized (error)
56 | ())
57 |
58 | (defun observe-notifications (dnc notification-name)
59 | (tagbody start
60 | (restart-case
61 | (if (boundp '*notification-handler*)
62 | [dnc @(addObserver:selector:name:object:)
63 | :pointer *notification-handler*
64 | :pointer @(handle-notification:)
65 | :pointer (objc-runtime::make-nsstring
66 | notification-name)
67 | :pointer (cffi:null-pointer)]
68 | (error 'notifications-not-initialized))
69 | (setup-and-retry ()
70 | (setup-notifications)
71 | (go start)))))
72 |
--------------------------------------------------------------------------------
/clog-dnc-player.lisp:
--------------------------------------------------------------------------------
1 | (defpackage :objc.clog-dnc-player
2 | (:use :cl :clog)
3 | (:export ))
4 | (in-package :objc.clog-dnc-player)
5 | (named-readtables:in-readtable :objc-readtable)
6 |
7 | (fw.lu:defclass+ store ()
8 | ((%track-name
9 | :accessor track-name
10 | :initform nil)
11 | (%track-artist
12 | :accessor track-artist
13 | :initform nil)
14 | (%track-album
15 | :accessor track-album
16 | :initform nil)
17 | (%player-state
18 | :accessor player-state
19 | :initform nil)))
20 | (defvar *store*)
21 |
22 | (defun incorporate (store info)
23 | (prog1 store
24 | (trivia:match info
25 | ((trivia:hash-table-entries
26 | "Name" name
27 | "Album" album
28 | "Artist" artist
29 | "Player State" player-state)
30 | (setf
31 | (track-name store) name
32 | (track-album store) album
33 | (track-artist store) artist
34 | (player-state store) player-state)))))
35 |
36 | (defun reducer-task (store)
37 | (lambda ()
38 | (loop
39 | for message = (sb-concurrency:receive-message
40 | objc.notification:*mailbox*)
41 | do (incorporate *store* message))))
42 |
43 | (defun on-new-window (body)
44 | (let ((name (create-section body :h2 :content "track"))
45 | (artist (create-div body :content "artist"))
46 | (album (create-div body :content "album"))
47 | (player-state (create-div body :content "player-state"))
48 | (play-pause (create-button body :content "play/pause")))
49 | (link-slot-to-element *store* track-name name)
50 | (link-slot-to-element *store* track-artist artist)
51 | (link-slot-to-element *store* track-album album)
52 | (link-slot-to-element *store* player-state player-state)
53 | (set-on-click play-pause
54 | (lambda (button)
55 | (declare (ignore button))
56 | [(objc.scripting-bridge::itunes-app) @(playpause)]?))))
57 |
58 | (defvar *initialized* nil)
59 | (defun doit ()
60 | (unless *initialized*
61 | (setf *initialized* t)
62 | (setf *store* (make-instance 'store))
63 | (bt:make-thread (reducer-task *store*) :name "Reducer")
64 | (objc.notification:setup-notifications)
65 | (objc.notification:observe-notifications (objc.notification:dnc)
66 | "com.apple.Music.playerInfo")
67 | (bt:make-thread 'objc.notification:main-loop-ticker)
68 | (set-on-new-window 'on-new-window :path "/player")))
69 |
--------------------------------------------------------------------------------
/reading-list-reader.lisp:
--------------------------------------------------------------------------------
1 | (defpackage :reading-list-reader
2 | (:use :cl )
3 | (:export ))
4 | (in-package :reading-list-reader)
5 |
6 | (serapeum:eval-always
7 | (named-readtables:in-readtable :objc-readtable))
8 |
9 | (defun slugify (s)
10 | (cl-ppcre:regex-replace-all "\\s+"
11 | (string-downcase s)
12 | "_"))
13 |
14 | (defun select-child (d title)
15 | (flet ((get-title (h)
16 | (equal (gethash "Title" h)
17 | title)))
18 | (fw.lu:let-each (:be *)
19 | (gethash "Children" d)
20 | (remove-if-not #'get-title *))))
21 |
22 | (defparameter *reading-list-location* "Library/Safari/Bookmarks.plist")
23 | (defun get-bookmark-filename ()
24 | (uiop:native-namestring
25 | (merge-pathnames *reading-list-location*
26 | (truename "~/"))))
27 |
28 | (defun translate-plist (fn)
29 | (objc-runtime.data-extractors:extract-from-objc
30 | (objc-runtime.data-extractors:get-plist fn)))
31 |
32 | (defun make-org-file (s reading-list-info)
33 | (format s "~&* Safari Reading List~%")
34 | (serapeum:mapply (serapeum:partial 'make-org-entry s)
35 | reading-list-info))
36 |
37 | (defun make-org-entry (s date title url preview tag)
38 | (format s "~&** ~a (~a) :~{~a:~}~% ~a~2% ~{~<~% ~1,80:;~a~> ~}~2%"
39 | title
40 | (local-time:format-timestring nil date
41 | :format local-time:+rfc3339-format/date-only+)
42 | (alexandria:ensure-list tag)
43 | url
44 | (serapeum:tokens preview)))
45 |
46 | (defun get-readinglist-info (bookmarks)
47 | (sort (mapcar 'extract-link-info
48 | (gethash "Children"
49 | (car
50 | (select-child bookmarks
51 | "com.apple.ReadingList"))))
52 | 'local-time:timestamp>
53 | :key 'car))
54 |
55 | (defun extract-link-info (link)
56 | (list (local-time:parse-rfc3339-timestring (or (fw.lu:pick '("ReadingList" "DateAdded") link)
57 | (fw.lu:pick '("ReadingList" "DateLastViewed") link)
58 | (fw.lu:pick '("ReadingListNonSync" "DateLastFetched") link)
59 | (local-time:now)))
60 | (fw.lu:pick '("URIDictionary" "title") link)
61 | (fw.lu:pick '("URLString") link)
62 | (plump:decode-entities (coerce (fw.lu:pick '("ReadingList" "PreviewText") link) 'simple-string) t)
63 | (fw.lu:may (slugify (fw.lu:pick '("ReadingListNonSync" "siteName") link)))))
64 |
65 | (defun main ()
66 | #+(and build sbcl)
67 | (progn (sb-ext:disable-debugger)
68 | (sb-alien:alien-funcall
69 | (sb-alien:extern-alien "disable_lossage_handler"
70 | (function sb-alien:void))))
71 | (make-org-file *standard-output*
72 | (get-readinglist-info
73 | (translate-plist
74 | (get-bookmark-filename)))))
75 |
--------------------------------------------------------------------------------
/readtable.lisp:
--------------------------------------------------------------------------------
1 | (in-package :objc-runtime)
2 |
3 | #+ccl
4 | (defgeneric send-message (object message &rest args)
5 | (:method ((object ccl:macptr) (message (eql 'alloc)) &rest args)
6 | (apply #'objc-msg-send object (ensure-selector "alloc") args)))
7 |
8 | (defun read-until (test symbol-prefix &optional stop-before-chars)
9 | "Read from a string until"
10 | (lambda (s c b)
11 | (declare (ignore c b))
12 | (let ((class-name (coerce (loop for next-char = (peek-char nil s nil nil t)
13 | while next-char
14 | until (funcall test next-char)
15 | collect (read-char s t nil t)
16 | finally (when (and (not (member next-char
17 | stop-before-chars))
18 | (funcall test next-char))
19 | (read-char s t nil t)))
20 |
21 | 'string)))
22 | `(,symbol-prefix ,class-name))))
23 |
24 | (defmacro objc-send (obj message return &rest args)
25 | (let* ((return-t (case return
26 | (:nsstring :pointer)
27 | (t return)))
28 | (result `(cffi:foreign-funcall "objc_msgSend"
29 | :pointer ,obj
30 | :pointer ,message
31 | ,@args
32 | ,return-t)))
33 | (case return
34 | (:nsstring `(objc-send ,result
35 | (ensure-selector "UTF8String")
36 | :string))
37 | (t result))))
38 |
39 | (defun read-objc-form (s char)
40 | (declare (ignore char))
41 | (let* ((info (read-delimited-list #\] s t))
42 | (safe-p (when (eql #\? (peek-char nil s nil #\p t))
43 | (read-char s t nil t)))
44 | (return-t (case (peek-char nil s nil #\p t)
45 | (#\# (read-char s t nil t) :int)
46 | (#\& (read-char s t nil t) :pointer)
47 | (#\@ (read-char s t nil t) :nsstring)
48 | (#\b (read-char s t nil t) :bool)
49 | (#\s (read-char s t nil t) :string)
50 | (t :pointer))))
51 | (when info
52 | (destructuring-bind (obj message . args) info
53 | (if safe-p
54 | `(safe-objc-msg-send ,return-t ,obj ,message ,@args)
55 | `(objc-send ,obj ,message ,return-t ,@args))))))
56 |
57 | (named-readtables:defreadtable :objc-readtable
58 | (:merge :standard)
59 | (:syntax-from :standard #\) #\])
60 | (:macro-char #\[ 'read-objc-form nil)
61 | (:dispatch-macro-char #\# #\@
62 | (lambda (s c b)
63 | c b
64 | (let ((class-name (coerce (loop for c = (peek-char nil s nil nil t)
65 | until (or (null c)
66 | (serapeum:whitespacep c)
67 | (member c
68 | '(#\) #\( #\[ #\])))
69 | collect (read-char s t nil t))
70 | 'string)))
71 | `(ensure-class ,class-name))))
72 | (:macro-char #\@ :dispatch t)
73 | (:dispatch-macro-char #\@ #\( (read-until (serapeum:op (char= _ #\)))
74 | 'ensure-selector))
75 | (:dispatch-macro-char #\@ #\" (read-until (serapeum:op (char= _ #\"))
76 | 'make-nsstring)))
77 |
--------------------------------------------------------------------------------
/objc-data-extractors.lisp:
--------------------------------------------------------------------------------
1 | ;; objc-data-extractor.lisp
2 |
3 |
4 | ;; [[file:~/git_repos/objc-lisp-bridge/README.org::*objc-data-extractor.lisp][objc-data-extractor.lisp:1]]
5 | (defpackage :objc-runtime.data-extractors
6 | (:use :cl )
7 | (:export
8 | #:extract-from-objc
9 | #:define-extractor
10 | #:clear-extractors
11 | #:add-extractor
12 | #:get-plist
13 | #:objc-typecase))
14 |
15 | (in-package :objc-runtime.data-extractors)
16 | (named-readtables:in-readtable :objc-readtable)
17 |
18 | (defun get-plist (file)
19 | [#@NSDictionary @(dictionaryWithContentsOfFile:)
20 | :pointer (objc-runtime::make-nsstring file)])
21 |
22 | (defun objc-subclass-p (sub super)
23 | (unless (or (cffi:null-pointer-p sub)
24 | (cffi:null-pointer-p super))
25 | (or (eql sub super)
26 | (= [sub @(isSubclassOfClass:) :pointer [super @(class)]]#
27 | 1))))
28 |
29 | (defun order-objc-classes (classes &rest r &key key)
30 | (declare (ignore key))
31 | (apply 'stable-sort
32 | (copy-seq classes)
33 | 'objc-subclass-p
34 | r))
35 |
36 | (defun objc-isa (obj class)
37 | (unless (or (cffi:null-pointer-p obj)
38 | (cffi:null-pointer-p class))
39 | (= [obj @(isKindOfClass:) :pointer class]#
40 | 1)))
41 |
42 | (defun objc-pick-by-type (obj pairs)
43 | (assoc obj
44 | (order-objc-classes pairs :key 'car)
45 | :test 'objc-isa))
46 |
47 | (serapeum:eval-always
48 | (defun make-cases (cases obj)
49 | (mapcar (serapeum:op
50 | `(if (objc-isa ,obj ,(car _1))
51 | (progn ,@(cdr _1))))
52 | cases)))
53 |
54 | (defmacro objc-typecase (form &body ((case-type &body case-handler) &rest cases))
55 | (alexandria:once-only (form)
56 | (let* ((initial-cases `((,case-type ,@case-handler) ,@(butlast cases)))
57 | (cases (fw.lu:rollup-list (make-cases initial-cases form)
58 | (if (eql t (caar (last cases)))
59 | `((progn ,@(cdar (last cases))))
60 | (make-cases (last cases) form)))))
61 | cases)))
62 |
63 | (defun map-nsarray (fn arr)
64 | (unless (and (cffi:pointerp arr)
65 | (objc-isa arr #@NSArray))
66 | (error "must provide a NSArray pointer"))
67 | (loop for x below [arr @(count)]#
68 | collect (funcall fn [arr @(objectAtIndex:) :int x])))
69 |
70 | (defun nsarray-contents (arr)
71 | (unless (and (cffi:pointerp arr)
72 | (objc-isa arr #@NSArray))
73 | (error "must provide a NSArray pointer"))
74 | (dotimes (n [arr @(count)]#)
75 | (let ((obj [arr @(objectAtIndex:) :int n ]))
76 | (objc-typecase obj
77 | (#@NSString (format t "~&string~%"))
78 | (#@NSArray (format t "~&array~%"))
79 | (#@NSDictionary (format t "~&dictionary~%"))
80 | (t (format t "~&other... ~s~%" (objc-runtime::objc-class-get-name
81 | (objc-runtime::object-get-class obj))))))))
82 |
83 | (defmacro funcall-some (fun &rest args)
84 | (alexandria:once-only (fun)
85 | `(if ,fun
86 | (funcall ,fun ,@args))))
87 |
88 | (defvar *objc-extractors* (list)
89 | "Functions called to extract specific data types")
90 |
91 | (defun extract-from-objc (obj)
92 | (objc-typecase obj
93 | (#@NSDate [[[[#@NSISO8601DateFormatter @(alloc)]
94 | @(init)]
95 | @(stringFromDate:) :pointer obj]
96 | @(UTF8String)]s)
97 | (#@NSString [obj @(UTF8String)]s)
98 | (#@NSNumber (parse-number:parse-number
99 | (objc-runtime::extract-nsstring
100 | [obj @(stringValue)])))
101 | (#@NSArray (map-nsarray #'extract-from-objc obj))
102 | (#@NSDictionary (fw.lu:alist-string-hash-table
103 | (pairlis (map-nsarray #'extract-from-objc [obj @(allKeys)])
104 | (map-nsarray #'extract-from-objc [obj @(allValues)]))))
105 | (t (or (funcall-some (cdr (objc-pick-by-type obj *objc-extractors*))
106 | obj)
107 | obj))))
108 |
109 | (defmacro define-extractor (class (o) &body body)
110 | `(serapeum:eval-always
111 | (add-extractor ,class
112 | (lambda (,o)
113 | ,@body))
114 | *objc-extractors*))
115 |
116 | (defun clear-extractors ()
117 | (setf *objc-extractors* ()))
118 |
119 | (serapeum:eval-always
120 | (defun add-extractor (class cb)
121 | (unless (member class *objc-extractors* :test 'cffi:pointer-eq :key #'car)
122 | (setf *objc-extractors*
123 | (merge 'list *objc-extractors* (list (cons class cb))
124 | 'objc-subclass-p
125 | :key 'car)))
126 | *objc-extractors*))
127 | ;; objc-data-extractor.lisp:1 ends here
128 |
--------------------------------------------------------------------------------
/clim-objc-browser.lisp:
--------------------------------------------------------------------------------
1 | (defpackage :clim-objc-browser
2 | (:use :clim-lisp :clim))
3 | (in-package :clim-objc-browser)
4 |
5 | (define-application-frame class-browser ()
6 | ((classes :initarg :classes :reader classes)
7 | (visible-classes :initform nil :accessor visible-classes)
8 | (current-class :initform nil :accessor current-class))
9 | (:panes (classes :application
10 | :incremental-redisplay t
11 | :display-function 'display-classes
12 | #+nil(:double-buffering t)
13 | )
14 | (methods :application
15 | :incremental-redisplay t
16 | :display-function 'display-methods)
17 | (int :interactor))
18 | (:pointer-documentation t)
19 | (:layouts (default (vertically ()
20 | (horizontally ()
21 | classes methods)
22 | int)))
23 | (:default-initargs
24 | :classes (sort (remove-if (serapeum:op
25 | (alexandria:starts-with #\_
26 | (objc-runtime::objc-class-get-name _)))
27 | (objc-runtime::get-classes))
28 | #'string-lessp
29 | :key 'objc-runtime::objc-class-get-name)))
30 |
31 | (defun reset-application-frame ()
32 | (setf (visible-classes clim:*application-frame*) nil
33 | (current-class clim:*application-frame*) nil
34 | (slot-value clim:*application-frame* 'classes)
35 | (sort (remove-if (serapeum:op (alexandria:starts-with #\_
36 | (objc-runtime::objc-class-get-name _)))
37 | (objc-runtime::get-classes))
38 | #'string-lessp
39 | :key 'objc-runtime::objc-class-get-name)))
40 |
41 | (define-presentation-type objc-class ())
42 | (define-presentation-method present (object (type objc-class) stream view &key)
43 | (declare (ignore view))
44 | (format stream "#[OBJC Class: ~a]"
45 | (objc-runtime::objc-class-get-name object)))
46 |
47 | (define-presentation-type objc-method ())
48 | (define-presentation-method present (object (type objc-method) stream view &key)
49 | (declare (ignore view))
50 | (format stream "@(~a)"
51 | (objc-runtime::get-method-name object)))
52 |
53 | (define-presentation-translator string-to-objc-class (string objc-class class-browser
54 | :tester ((inp) (objc-runtime:ensure-class inp))
55 | :tester-definitive t)
56 | (inp)
57 | (format *terminal-io* "~&translating ~s to an objc-class" inp)
58 | (objc-runtime:ensure-class inp))
59 |
60 | (defun display-classes (frame pane)
61 | (updating-output (pane :unique-id (or (visible-classes frame)
62 | (classes frame))
63 | :id-test 'eq)
64 | (loop for class in (or (visible-classes frame)
65 | (classes frame))
66 | do
67 | (updating-output (pane :unique-id (cffi:pointer-address class)
68 | :id-test 'eql
69 | :cache-value class
70 | :cache-test 'eql)
71 | (with-output-as-presentation (pane class 'objc-class)
72 | (format pane "~& ~a~%" (objc-runtime::objc-class-get-name class)))))))
73 |
74 | (defun display-methods (frame pane)
75 | (updating-output (pane :unique-id (current-class frame)
76 | :id-test 'eq)
77 | (when (current-class frame)
78 | (loop for method in (sort (objc-runtime::get-methods (current-class frame))
79 | 'string<
80 | :key 'objc-runtime::get-method-name)
81 | do
82 | (with-output-as-presentation (pane method 'objc-method)
83 | (format pane " Method: ~a~%" (objc-runtime::get-method-name method)))))))
84 |
85 | (define-class-browser-command (com-get-methods :name t :menu t) ((the-class objc-class :gesture :select))
86 | (if (cffi:pointerp the-class)
87 | (setf (current-class *application-frame*) the-class)
88 | (format *terminal-io* "~&The value ~s is not a pointer to a class, but a ~s" the-class (type-of the-class))))
89 |
90 |
91 | (define-class-browser-command (com-refresh-classes :name t :menu t) ()
92 | (reset-application-frame))
93 |
94 | (define-class-browser-command (com-filter-classes :name t :menu t) ((prefix string))
95 | (setf (visible-classes *application-frame*)
96 | (remove-if-not (serapeum:op
97 | (alexandria:starts-with-subseq prefix _ :test #'char-equal))
98 | (classes *application-frame*)
99 | :key 'objc-runtime::objc-class-get-name)))
100 |
101 | (defun main ()
102 | (clim:run-frame-top-level
103 | (clim:make-application-frame 'class-browser)))
104 |
--------------------------------------------------------------------------------
/bundle-utils.lisp:
--------------------------------------------------------------------------------
1 | (in-package :objc-runtime.bundle-utils)
2 | (named-readtables:in-readtable :objc-readtable)
3 |
4 | (defun bundle-resource-root ()
5 | (uiop:ensure-directory-pathname
6 | [[[#@NSBundle @(mainBundle)] @(resourceURL)] @(fileSystemRepresentation)]s))
7 |
8 | (defun application-support-directory (&optional (scope :user))
9 | (let ((next-step (make-pathname :directory (list :relative (objc-runtime.data-extractors:extract-from-objc
10 | [[[#@NSBundle @(mainBundle)]
11 | @(infoDictionary)]
12 | @(objectForKey:)
13 | :pointer @"CFBundleIdentifier"])))))
14 | (car
15 | (mapcan (alexandria:compose 'serapeum:unsplice
16 | (lambda (p) (when p (merge-pathnames next-step p)))
17 | 'probe-file)
18 | (mapcar (lambda (it) [it @(fileSystemRepresentation)]?s)
19 | (objc-runtime.data-extractors:extract-from-objc
20 | [[#@NSFileManager @(defaultManager)] @(URLsForDirectory:inDomains:)
21 | :int 14 ;; NSApplicationSupportDirectory
22 | :int (ccase scope
23 | (:user 1)
24 | (:local 2)
25 | (:network 4))]))))))
26 |
27 | (defun setup-bundle-logical-pathnames ()
28 | (setf (logical-pathname-translations "BUNDLE")
29 | `(("BUNDLE:RESOURCES;**;*.*.*" ,(bundle-resource-root))
30 | ("BUNDLE:SUPPORT;USER;**;*.*.*" ,(application-support-directory :user))
31 | ("BUNDLE:SUPPORT;LOCAL;**;*.*.*" ,(application-support-directory :local)))))
32 |
33 | (defun ensure-application-support ()
34 | (setup-bundle-logical-pathnames)
35 | (translate-logical-pathname
36 | (ensure-directories-exist
37 | #P"BUNDLE:APPLICATION-SUPPORT;USER;")))
38 |
39 | (named-readtables:defreadtable config
40 | (:case :preserve)
41 | (:syntax-from :standard #\) #\))
42 | (:macro-char #\( (lambda (s c)
43 | c
44 | (read-delimited-list #\) s t))
45 | nil)
46 | (:macro-char #\, (lambda (s c)
47 | c
48 | (values))
49 | nil)
50 | (:syntax-from :standard #\" #\")
51 | (:syntax-from :standard #\: #\:)
52 | (:syntax-from :standard #\) #\})
53 | (:macro-char #\{ (lambda (s c)
54 | c
55 | (alexandria:plist-hash-table (read-delimited-list #\} s t)
56 | :test 'equal))
57 | nil)
58 | (:syntax-from :standard #\) #\])
59 | (:macro-char #\[ (lambda (s c)
60 | c
61 | (apply #'vector (read-delimited-list #\] s t)))
62 | nil))
63 |
64 | (defparameter *config-pprint*
65 | (copy-pprint-dispatch))
66 |
67 | (set-pprint-dispatch 'hash-table
68 | (lambda (s hash-table)
69 | (pprint-logical-block (s nil)
70 | (princ "{" s)
71 | (let ((v (fset:convert 'list (fset:convert 'fset:map hash-table))))
72 | (when v
73 | (pprint-logical-block (s v)
74 | (pprint-indent :block 0 s)
75 | (loop do
76 | (destructuring-bind (key . value) (pprint-pop)
77 | (format s "~s ~s" key value)
78 | (pprint-exit-if-list-exhausted)
79 | (princ ", " s)
80 | (pprint-newline :linear s))))))
81 | (princ #\} s)))
82 | 1 *config-pprint*)
83 |
84 | (set-pprint-dispatch 'vector
85 | (lambda (s vector)
86 | (pprint-logical-block (s nil)
87 | (princ "[" s)
88 | (let ((v (coerce vector 'list)))
89 | (when v
90 | (pprint-logical-block (s v)
91 | (pprint-indent :block 0 s)
92 | (loop do
93 | (prin1 (pprint-pop) s)
94 | (pprint-exit-if-list-exhausted)
95 | (princ ", " s)
96 | (pprint-newline :linear s)))))
97 | (princ #\] s)))
98 | 1 *config-pprint*)
99 |
100 | (defun print-for-config (object s)
101 | (let ((*print-readably* t)
102 | (*print-pprint-dispatch* *config-pprint*))
103 | (pprint object s)))
104 |
105 | (defun read-from-config (s)
106 | (let ((*readtable* (named-readtables:find-readtable 'config)))
107 | (read s)))
108 |
--------------------------------------------------------------------------------
/scripting-bridge.lisp:
--------------------------------------------------------------------------------
1 | (defpackage :objc.scripting-bridge
2 | (:import-from :objc.manipulators :defun-ct :shortcut :<> :ext :sel)
3 | (:use :cl :cffi)
4 | (:export
5 | #:app))
6 | (in-package :objc.scripting-bridge)
7 | (named-readtables:in-readtable :objc-readtable)
8 |
9 | (serapeum:eval-always
10 | (define-foreign-library scripting-bridge
11 | (:darwin (:framework "ScriptingBridge"))))
12 |
13 | (use-foreign-library scripting-bridge)
14 |
15 | (defun app (bundle-id)
16 | [#@SBApplication @(applicationWithBundleIdentifier:)
17 | :pointer (objc-runtime:make-nsstring bundle-id)])
18 |
19 | (defun itunes-app ()
20 | (app "com.apple.Music"))
21 |
22 | (defun safari-app ()
23 | (app "com.apple.Safari"))
24 |
25 | (defclass sbsafari ()
26 | ((%app-ref :reader app-ref :initform (safari-app))))
27 |
28 | (defgeneric windows (object)
29 | (:method ((object sbsafari))
30 | (mapcar 'safari-window
31 | (objc-runtime.data-extractors:extract-from-objc
32 | [(app-ref object) @(windows)]?))))
33 |
34 | (fw.lu:defclass+ safari-window ()
35 | ((%window-ref :reader window-ref :initarg :window-ref)))
36 |
37 | (defgeneric name (thing)
38 | (:method ((thing safari-window))
39 | [(window-ref thing) @(name)]@))
40 |
41 | (defgeneric tabs (object)
42 | (:method ((object safari-window))
43 | (mapcar 'safari-tab
44 | (objc-runtime.data-extractors:extract-from-objc
45 | [(window-ref object) @(tabs)]))))
46 |
47 | (fw.lu:defclass+ safari-tab ()
48 | ((%tab-ref :reader tab-ref :initarg :tab-ref)))
49 |
50 | (defgeneric source (tab)
51 | (:method ((tab safari-tab))
52 | [(tab-ref tab) @(source)]@))
53 | (defgeneric text (tab)
54 | (:method ((tab safari-tab))
55 | [(tab-ref tab) @(text)]@))
56 | (defgeneric url (tab)
57 | (:method ((tab safari-tab))
58 | [(tab-ref tab) @(URL)]@))
59 |
60 | (defun current-track-info (itunes)
61 | (let* ((current-track [itunes @(currentTrack)]))
62 | (format t "~&Track: ~A (~v,1,0,'⋆<~>)~%Album: ~a (~v,1,0,'*<~>)~%Artist: ~a~%"
63 | [current-track @(name)]@
64 | (/ [current-track @(rating)]# 20)
65 | [current-track @(album)]@
66 | (/ [current-track @(albumRating)]# 10)
67 | [current-track @(artist)]@)))
68 |
69 | (defun-ct tab-info ()
70 | (data-lens:juxt
71 | (<> (ext) (sel t @(name)))
72 | (<> (ext) (sel t @(URL)))))
73 |
74 | (data-lens:shortcut window-info data-lens:juxt
75 | (sel :int @(id))
76 | #'identity
77 | (sel :nsstring @(name)))
78 |
79 | (defun safari-tab-info (safari)
80 | (funcall (data-lens:over (tab-info))
81 | (mapcan (<> (ext) (sel t @(tabs)))
82 | (objc-runtime.data-extractors:extract-from-objc
83 | [safari @(windows)]))))
84 |
85 | (defun format-tab-info (info)
86 | (format t "~{~:@{** ~a~% ~a~%~}~2%~}" info))
87 |
88 | (defun safari-main ()
89 | (format-tab-info
90 | (safari-tab-info
91 | (safari-app))))
92 |
93 | (defun count-invocations (hof)
94 | (lambda (f &rest hof-args)
95 | (let ((count 0))
96 | (declare (dynamic-extent count))
97 | (flet ((nested-lambda (&rest args)
98 | (prog1 (apply f count args)
99 | (incf count))))
100 | (apply hof #'nested-lambda hof-args)))))
101 |
102 | (defmacro comment (&body b)
103 | b ())
104 |
105 | #+nil
106 | (comment
107 | (defun kebab-case (s)
108 | (loop
109 | for start = 0 then end
110 | for end = (position-if 'upper-case-p s) then (when start (position-if 'upper-case-p s :start (1+ end)))
111 | while start
112 | collect (string-downcase (subseq s start end)) into parts
113 | finally (return (serapeum:string-join parts #\-))))
114 |
115 | (defun get-method-symbol (selector-name package)
116 | (funcall (alexandria:compose (lambda (x) (intern x package))
117 | #'string-upcase
118 | (lambda (x) (substitute #\- #\:
119 | (string-trim ":-" x)))
120 | 'kebab-case)
121 | selector-name))
122 |
123 | (defun intern-method (selector-name package)
124 | (let ((symbol (get-method-symbol selector-name package)))
125 | (format t "~&~s ~s~%" symbol selector-name)
126 | (if (alexandria:starts-with-subseq "set" selector-name)
127 | (setf (fdefinition `(setf ,symbol))
128 | (lambda (new-val receiver &rest r)
129 | (declare (ignore r))
130 | (objc-runtime:objc-msg-send receiver (objc-runtime::ensure-selector selector-name) :pointer new-val)))
131 | (setf (fdefinition symbol)
132 | (sel (objc-runtime::ensure-selector selector-name))))))
133 |
134 | (defun populate-package (objc-class package)
135 | (mapc (lambda (method-name)
136 | (intern-method method-name package))
137 | (objc-runtime:get-method-names objc-class)))
138 |
139 | (defmacro define-objc-call (selector (&rest argument-specs) result-type &optional extractor)
140 | (declare (ignorable extractor))
141 | `(defun ,(get-method-symbol (cadr selector) *package*) (receiver ,@(mapcar #'car argument-specs))
142 | ,(case result-type
143 | (:string `(objc-runtime:objc-msg-send-string receiver ,selector ,@(mapcan #'reverse argument-specs)))
144 | ((:long :int) `(objc-runtime:objc-msg-send-int receiver ,selector ,@(mapcan #'reverse argument-specs)))
145 | (t `(objc-runtime:objc-msg-send receiver ,selector ,@(mapcan #'reverse argument-specs))))))
146 |
147 | (defmacro define-objc (() &body calls)
148 | `(progn ,@(loop for call in calls
149 | collect `(define-objc-call ,@call))))
150 |
151 | (define-objc-call @(init) () :pointer)
152 | (define-objc-call @(sharedApplication) () :pointer)
153 | )
154 |
--------------------------------------------------------------------------------
/demo-app.svg:
--------------------------------------------------------------------------------
1 |
--------------------------------------------------------------------------------
/README.org:
--------------------------------------------------------------------------------
1 | * Intro
2 |
3 | CCL and LispWorks and other implementations have their own bridges to
4 | the objective-c runtime. This project is an attempt to create a
5 | bridge that only uses CFFI so that arbitrary lisp implementations can
6 | produce native mac GUIs. In the long run, I hope to use this as the
7 | basis for a new mac-native backend for McClim: but we'll see if that
8 | ever happens.
9 |
10 | For the time being, though, this only works on CCL and (sort-of) on
11 | LispWorks: it works like 95% on SBCL, but there's some weird issue
12 | that's preventing the window from showing. I hae not tested the code
13 | on any other implementations, but doing so will require changing a
14 | couple places in objc-runtime.lisp to inform the code about the new
15 | lisp's ffi types.
16 |
17 | * Installing
18 |
19 | 1. clone fwoar.lisputils from
20 | https://github.com/fiddlerwoaroof/fwoar.lisputils and put it
21 | somewhere quicklisp can find it (e.g. ~/quicklisp/local-projects)
22 |
23 | 2. clone cffi from https://github.com/cffi/cffi and put it in the same
24 | place (on Big Sur, at least, I need changes that haven't made it to
25 | Quicklisp)
26 |
27 | 3. Install rsvg-convert:
28 | #+BEGIN_SRC sh :tangle no
29 | brew install librsvg
30 | #+END_SRC
31 |
32 | 4. build + run the demo:
33 | #+BEGIN_SRC sh :tangle no
34 | make mkapp CL=/path/to/cl
35 | open demo.app
36 | #+END_SRC
37 |
38 | * Show me the code!
39 |
40 | From demo-app.lisp:
41 |
42 | #+BEGIN_SRC lisp :tangle no
43 | (defun main ()
44 | (trivial-main-thread:with-body-in-main-thread (:blocking t)
45 | [#@NSAutoReleasePool @(new)]
46 | [#@NSApplication @(sharedApplication)]
47 | [objc-runtime::ns-app @(setActivationPolicy:) :int 0]
48 |
49 | (objc-runtime::objc-register-class-pair
50 | (demo-app::make-app-delegate-class '("actionButton"
51 | "alertButton"
52 | "profitButton")))
53 |
54 | (demo-app::load-nib "MainMenu")
55 |
56 | (let ((app-delegate [objc-runtime::ns-app @(delegate)]))
57 | (demo-app::make-button-delegate (value-for-key app-delegate "actionButton")
58 | (cffi:callback do-things-action))
59 | (demo-app::make-button-delegate (value-for-key app-delegate "alertButton")
60 | (cffi:callback alert-action))
61 | (demo-app::make-button-delegate (value-for-key app-delegate "profitButton")
62 | (cffi:callback profit-action)))
63 |
64 | [objc-runtime::ns-app @(activateIgnoringOtherApps:) :boolean t]
65 | [objc-runtime::ns-app @(run)]))
66 |
67 | #+END_SRC
68 |
69 | * In-depth example
70 | ** Type-directed Objective-C extractors
71 |
72 | #+name: extractor-framework
73 | #+begin_src lisp :tangle no :results no :comments both
74 | (defvar *objc-extractors* (list)
75 | "Functions called to extract specific data types")
76 |
77 | (defun extract-from-objc (obj)
78 | (objc-typecase obj
79 | (#@NSDate [[[[#@NSISO8601DateFormatter @(alloc)]
80 | @(init)]
81 | @(stringFromDate:) :pointer obj]
82 | @(UTF8String)]s)
83 | (#@NSString [obj @(UTF8String)]s)
84 | (#@NSNumber (parse-number:parse-number
85 | (objc-runtime::extract-nsstring
86 | [obj @(stringValue)])))
87 | (#@NSArray (map-nsarray #'extract-from-objc obj))
88 | (#@NSDictionary (fw.lu:alist-string-hash-table
89 | (pairlis (map-nsarray #'extract-from-objc [obj @(allKeys)])
90 | (map-nsarray #'extract-from-objc [obj @(allValues)]))))
91 | (t (or (funcall-some (cdr (objc-pick-by-type obj *objc-extractors*))
92 | obj)
93 | obj))))
94 |
95 | (defmacro define-extractor (class (o) &body body)
96 | `(serapeum:eval-always
97 | (add-extractor ,class
98 | (lambda (,o)
99 | ,@body))
100 | ,*objc-extractors*))
101 |
102 | (defun clear-extractors ()
103 | (setf *objc-extractors* ()))
104 |
105 | (serapeum:eval-always
106 | (defun add-extractor (class cb)
107 | (unless (member class *objc-extractors* :test 'cffi:pointer-eq :key #'car)
108 | (setf *objc-extractors*
109 | (merge 'list *objc-extractors* (list (cons class cb))
110 | 'objc-subclass-p
111 | :key 'car)))
112 | ,*objc-extractors*))
113 | #+end_src
114 |
115 | ** Reading List to Org-file converter
116 |
117 | The entry-point is fairly unremarkable: it delegates most of the work to other functions and disables the debugger so
118 | that this doesn't blow up when an error occurs in non-interactive mode.
119 |
120 | #+name: r-l-r-main
121 | #+begin_src lisp :tangle no :results no :noweb yes
122 | (defun main ()
123 | <>
124 | (make-org-file *standard-output*
125 | (get-readinglist-info
126 | (translate-plist
127 | (get-bookmark-filename)))))
128 | #+end_src
129 |
130 | This pair of functions builds an org file from data extracted from the Safari bookmark file.
131 |
132 | #+name: make-org-file
133 | #+begin_src lisp :tangle no :results no
134 | (defun make-org-file (s reading-list-info)
135 | (format s "~&* Safari Reading List~%")
136 | (serapeum:mapply (serapeum:partial 'make-org-entry s)
137 | reading-list-info))
138 |
139 | (defun make-org-entry (s date title url preview tag)
140 | (format s "~&** ~a (~a) :~{~a:~}~% ~a~2% ~{~<~% ~1,80:;~a~> ~}~2%"
141 | title
142 | (local-time:format-timestring nil date
143 | :format local-time:+rfc3339-format/date-only+)
144 | (alexandria:ensure-list tag)
145 | url
146 | (serapeum:tokens preview)))
147 | #+end_src
148 |
149 | Here we extract the data from Bookmarks.plist using our polymorphic objc data extractor framework
150 |
151 | #+name: translate-plist
152 | #+begin_src lisp :tangle no :results no
153 | (defparameter *reading-list-location* "Library/Safari/Bookmarks.plist")
154 | (defun get-bookmark-filename ()
155 | (uiop:native-namestring
156 | (merge-pathnames *reading-list-location*
157 | (truename "~/"))))
158 |
159 | (defun translate-plist (fn)
160 | (objc-runtime.data-extractors:extract-from-objc
161 | (objc-runtime.data-extractors:get-plist fn)))
162 | #+end_src
163 |
164 | #+name: translate-data
165 | #+begin_src lisp :tangle no :results no
166 | (defun get-readinglist-info (bookmarks)
167 | (sort (mapcar 'extract-link-info
168 | (gethash "Children"
169 | (car
170 | (select-child bookmarks
171 | "com.apple.ReadingList"))))
172 | 'local-time:timestamp>
173 | :key 'car))
174 |
175 | (defun extract-link-info (link)
176 | (list (local-time:parse-rfc3339-timestring (or (fw.lu:pick '("ReadingList" "DateAdded") link)
177 | (fw.lu:pick '("ReadingList" "DateLastViewed") link)
178 | (fw.lu:pick '("ReadingListNonSync" "DateLastFetched") link)
179 | (local-time:now)))
180 | (fw.lu:pick '("URIDictionary" "title") link)
181 | (fw.lu:pick '("URLString") link)
182 | (plump:decode-entities (coerce (fw.lu:pick '("ReadingList" "PreviewText") link) 'simple-string) t)
183 | (fw.lu:may (slugify (fw.lu:pick '("ReadingListNonSync" "siteName") link)))))
184 | #+end_src
185 |
186 | ** Appendices
187 |
188 | *** objc-data-extractor.lisp
189 |
190 | #+begin_src lisp :tangle objc-data-extractors.lisp :noweb yes :comments both
191 | (defpackage :objc-runtime.data-extractors
192 | (:use :cl )
193 | (:export
194 | #:extract-from-objc
195 | #:define-extractor
196 | #:clear-extractors
197 | #:add-extractor
198 | #:get-plist))
199 |
200 | (in-package :objc-runtime.data-extractors)
201 | (named-readtables:in-readtable :objc-readtable)
202 |
203 | (defun get-plist (file)
204 | [#@NSDictionary @(dictionaryWithContentsOfFile:)
205 | :pointer (objc-runtime::make-nsstring file)])
206 |
207 | (defun objc-subclass-p (sub super)
208 | (unless (or (cffi:null-pointer-p sub)
209 | (cffi:null-pointer-p super))
210 | (or (eql sub super)
211 | (= [sub @(isSubclassOfClass:) :pointer [super @(class)]]#
212 | 1))))
213 |
214 | (defun order-objc-classes (classes &rest r &key key)
215 | (declare (ignore key))
216 | (apply 'stable-sort
217 | (copy-seq classes)
218 | 'objc-subclass-p
219 | r))
220 |
221 | (defun objc-isa (obj class)
222 | (unless (or (cffi:null-pointer-p obj)
223 | (cffi:null-pointer-p class))
224 | (= [obj @(isKindOfClass:) :pointer class]#
225 | 1)))
226 |
227 | (defun objc-pick-by-type (obj pairs)
228 | (assoc obj
229 | (order-objc-classes pairs :key 'car)
230 | :test 'objc-isa))
231 |
232 | (serapeum:eval-always
233 | (defun make-cases (cases obj)
234 | (mapcar (serapeum:op
235 | `(if (objc-isa ,obj ,(car _1))
236 | (progn ,@(cdr _1))))
237 | cases)))
238 |
239 | (defmacro objc-typecase (form &body ((case-type &body case-handler) &rest cases))
240 | (alexandria:once-only (form)
241 | (let* ((initial-cases `((,case-type ,@case-handler) ,@(butlast cases)))
242 | (cases (fw.lu:rollup-list (make-cases initial-cases form)
243 | (if (eql t (caar (last cases)))
244 | `((progn ,@(cdar (last cases))))
245 | (make-cases (last cases) form)))))
246 | cases)))
247 |
248 | (defun map-nsarray (fn arr)
249 | (unless (and (cffi:pointerp arr)
250 | (objc-isa arr #@NSArray))
251 | (error "must provide a NSArray pointer"))
252 | (loop for x below [arr @(count)]#
253 | collect (funcall fn [arr @(objectAtIndex:) :int x])))
254 |
255 | (defun nsarray-contents (arr)
256 | (unless (and (cffi:pointerp arr)
257 | (objc-isa arr #@NSArray))
258 | (error "must provide a NSArray pointer"))
259 | (dotimes (n [arr @(count)]#)
260 | (let ((obj [arr @(objectAtIndex:) :int n ]))
261 | (objc-typecase obj
262 | (#@NSString (format t "~&string~%"))
263 | (#@NSArray (format t "~&array~%"))
264 | (#@NSDictionary (format t "~&dictionary~%"))
265 | (t (format t "~&other... ~s~%" (objc-runtime::objc-class-get-name
266 | (objc-runtime::object-get-class obj))))))))
267 |
268 | (defmacro funcall-some (fun &rest args)
269 | (alexandria:once-only (fun)
270 | `(if ,fun
271 | (funcall ,fun ,@args))))
272 |
273 | <>
274 | #+end_src
275 |
276 | *** build-reading-list-reader.sh
277 |
278 | #+begin_src sh :tangle build-reading-list-reader.sh
279 | #!/usr/bin/env bash
280 | set -eu -x -o pipefail
281 |
282 | cd "$(dirname $0)"
283 | mkdir -p dist
284 |
285 | pushd dist
286 | rm -rf fwoar.lisputils
287 | git clone https://github.com/fiddlerwoaroof/fwoar.lisputils.git
288 | popd
289 |
290 | export CL_SOURCE_REGISTRY="$PWD/dist//"
291 | sbcl --no-userinit \
292 | --load ~/quicklisp/setup.lisp \
293 | --load build.lisp
294 | #+end_src
295 |
296 | *** build.lisp
297 |
298 | #+begin_src lisp :mkdirp yes :results no :noweb yes :tangle build.lisp
299 | (eval-when (:compile-toplevel :load-toplevel :execute)
300 | (setf *default-pathname-defaults* (truename "~/git_repos/objc-lisp-bridge/"))
301 | (load (compile-file "objc-runtime.asd")))
302 |
303 | (eval-when (:compile-toplevel :load-toplevel :execute)
304 | (ql:quickload '(:objc-runtime :yason :plump :cl-ppcre)))
305 |
306 | (load "reading-list-reader.lisp")
307 |
308 | (eval-when (:compile-toplevel :load-toplevel :execute)
309 | (sb-ext:save-lisp-and-die "reading-list2org"
310 | :toplevel (intern "MAIN"
311 | "READING-LIST-READER")
312 | :executable t))
313 | #+end_src
314 |
315 | *** reading-list-reader.lisp
316 |
317 | #+begin_src lisp :mkdirp yes :results no :noweb yes :tangle reading-list-reader.lisp
318 | (defpackage :reading-list-reader
319 | (:use :cl )
320 | (:export ))
321 | (in-package :reading-list-reader)
322 |
323 | (serapeum:eval-always
324 | (named-readtables:in-readtable :objc-readtable))
325 |
326 | (defun slugify (s)
327 | (cl-ppcre:regex-replace-all "\\s+"
328 | (string-downcase s)
329 | "_"))
330 |
331 | (defun select-child (d title)
332 | (flet ((get-title (h)
333 | (equal (gethash "Title" h)
334 | title)))
335 | (fw.lu:let-each (:be *)
336 | (gethash "Children" d)
337 | (remove-if-not #'get-title *))))
338 |
339 | <>
340 |
341 | <>
342 |
343 | <>
344 |
345 | <>
346 | #+end_src
347 |
348 | #+name: disable-sbcl-debugger
349 | #+begin_src lisp :tangle no
350 | ,#+(and build sbcl)
351 | (progn (sb-ext:disable-debugger)
352 | (sb-alien:alien-funcall
353 | (sb-alien:extern-alien "disable_lossage_handler"
354 | (function sb-alien:void))))
355 | #+end_src
356 |
357 |
358 | # Local Variables:
359 | # fill-column: 120 :
360 | # End:
361 |
--------------------------------------------------------------------------------
/objc-runtime.lisp:
--------------------------------------------------------------------------------
1 | (in-package :objc-runtime)
2 | (serapeum:eval-always
3 | (named-readtables:in-readtable :objc-readtable))
4 |
5 | (serapeum:eval-always
6 | (cffi:define-foreign-library cocoa
7 | (:darwin (:framework "Cocoa")))
8 | (cffi:define-foreign-library foundation
9 | (:darwin (:framework "Foundation")))
10 | (cffi:define-foreign-library appkit
11 | (:darwin (:framework "AppKit"))))
12 |
13 | (use-foreign-library foundation)
14 | (use-foreign-library cocoa)
15 | (use-foreign-library appkit)
16 |
17 | (defctype o-class :pointer)
18 | (defctype o-selector :pointer)
19 |
20 | (defcfun (objc-look-up-class "objc_lookUpClass" :library foundation)
21 | o-class
22 | (name :string))
23 |
24 | (defcfun (objc-allocate-class-pair "objc_allocateClassPair" :library foundation)
25 | :pointer
26 | (superclass :pointer)
27 | (name :string)
28 | (extra-bytes :int))
29 |
30 | (defcfun (objc-register-class-pair "objc_registerClassPair" :library foundation)
31 | :void
32 | (superclass :pointer))
33 |
34 | (defcfun (objc-get-protocol "objc_getProtocol" :library foundation)
35 | :pointer
36 | (name :string))
37 |
38 | (defcfun (class-add-protocol "class_addProtocol" :library foundation)
39 | :boolean
40 | (class :pointer)
41 | (protocol :pointer))
42 |
43 | (serapeum:eval-always
44 | (defctype sizet
45 | :ulong
46 | #+32-bit-target :uint))
47 |
48 | (defcfun (class-add-ivar "class_addIvar" :library foundation)
49 | :boolean
50 | (class :pointer)
51 | (name :string)
52 | (size :ulong)
53 | (alignment :uint8)
54 | (types :string))
55 |
56 | (defun add-pointer-ivar (class name)
57 | (class-add-ivar class name
58 | (foreign-type-size :pointer)
59 | (floor (log (foreign-type-size :pointer)
60 | 2))
61 | "@"))
62 |
63 |
64 | #+nil
65 | (defun make-app-delegate-class (outlets)
66 | (let ((app-delegate-class (objc-runtime::objc-allocate-class-pair
67 | #@NSObject "AppDelegate" 0)))
68 | (objc-runtime:add-pointer-ivar app-delegate-class "window")
69 | (objc-runtime:add-pointer-ivar app-delegate-class "delegate")
70 |
71 | (loop for outlet in outlets do
72 | (objc-runtime:add-pointer-ivar app-delegate-class outlet))
73 |
74 | app-delegate-class))
75 |
76 | #+(or)
77 | (defun %setup-objc-class (name base ivars)
78 | (let ((class-pair (objc-allocate-class-pair base name 0)))
79 | (loop for ivar in ivars
80 | )))
81 |
82 | (defcfun (objc-class-get-name "class_getName" :library foundation)
83 | :string
84 | (cls o-class))
85 |
86 | (defcfun (objc-class-get-superclass "class_getSuperclass" :library foundation)
87 | :pointer
88 | (cls o-class))
89 |
90 | (defcfun (objc-get-class-list "objc_getClassList" :library foundation)
91 | :int
92 | (cls-buffer o-class)
93 | (buffer-count :int))
94 |
95 | (defcfun (sel-register-name "sel_registerName" :library foundation)
96 | o-selector
97 | (name :string))
98 |
99 | (defmacro safe-objc-msg-send (result-type thing selector &rest args)
100 | (alexandria:once-only (thing selector)
101 | `(if [,thing @(respondsToSelector:) :pointer ,selector]b
102 | ,(ccase result-type
103 | (:string `[,thing ,selector ,@args]s)
104 | (:nsstring `[,thing ,selector ,@args]@)
105 | (:pointer `[,thing ,selector ,@args])
106 | (:int `[,thing ,selector ,@args]#)
107 | (:bool `[,thing ,selector ,@args]b))
108 | (error "invalid selector"))))
109 |
110 | ;;; This is a macro, because objc-msg-send is a macro.... which makes "apply" impossible
111 | ;;; \o/
112 | (defmacro objc-msg-send-nsstring (thing selector &rest args)
113 | `[[,thing ,selector ,@args] @(UTF8String)]s)
114 |
115 | (defmacro objc-msg-send-bool (thing selector &rest args)
116 | `(= 1 [,thing ,selector ,@args]#))
117 |
118 | (defcfun (class-copy-method-list "class_copyMethodList" :library foundation)
119 | :pointer
120 | (cls o-class)
121 | (numMethods (:pointer :int)))
122 |
123 | (defcfun (method-get-name "method_getName")
124 | :string
125 | (method :pointer))
126 |
127 | (defcfun (method-get-type-encoding "method_getTypeEncoding")
128 | :string
129 | (method :pointer))
130 |
131 | (defcfun (sel-get-name "sel_getName")
132 | :string
133 | (sel o-selector))
134 |
135 | (defcfun (class-get-instance-variable "class_getInstanceVariable" :library foundation)
136 | :pointer
137 | (cls o-class)
138 | (name :string))
139 |
140 | (defcfun (class-add-method "class_addMethod" :library foundation)
141 | :boolean
142 | (class :pointer)
143 | (selector :pointer)
144 | (cb :pointer)
145 | (type :string))
146 |
147 |
148 | (defcfun (object-get-class "object_getClass" :library foundation)
149 | :pointer
150 | (object :pointer))
151 |
152 | (defcfun (object-get-ivar "object_getIvar" :library foundation)
153 | :pointer
154 | (object :pointer)
155 | (ivar :pointer))
156 |
157 | (defcfun (object-get-instance-variable "object_getInstanceVariable" :library foundation)
158 | :pointer
159 | (object :pointer)
160 | (name :string)
161 | (out :pointer))
162 |
163 | (defcfun (class-get-property "class_getProperty" :library foundation)
164 | :pointer
165 | (cls o-class)
166 | (name :string))
167 |
168 | (defcstruct objc-property-attribute-t
169 | (name :string)
170 | (value :string))
171 |
172 | (defcfun (class-add-property "class_addProperty" :library foundation)
173 | :pointer
174 | (cls o-class)
175 | (name :string)
176 | (attributes (:pointer (:struct objc-property-attribute-t)))
177 | (attribute-count :unsigned-int))
178 |
179 | (defcfun (property-copy-attribute-value "property_copyAttributeValue" :library foundation)
180 | :string
181 | (prop :pointer)
182 | (name :string))
183 |
184 |
185 | (defcfun (property-get-attributes "property_getAttributes" :library foundation)
186 | :string
187 | (prop :pointer))
188 |
189 | (defun get-classes ()
190 | (let ((num-classes (objc-get-class-list (null-pointer) 0))
191 | (result (list)))
192 | (with-foreign-object (classes :pointer num-classes)
193 | (dotimes (n (objc-get-class-list classes num-classes) (nreverse result))
194 | (push (mem-aref classes :pointer n)
195 | result)))))
196 |
197 | (defgeneric get-methods (class)
198 | (:method ((class string))
199 | (get-methods (objc-look-up-class class)))
200 |
201 | #+ccl
202 | (:method ((class ccl:macptr))
203 | (with-foreign-object (num-methods :int)
204 | (let ((methods (class-copy-method-list class num-methods)))
205 | (let ((result (list)))
206 | (dotimes (n (mem-aref num-methods :int) (nreverse result))
207 | (push (mem-aref methods :pointer n)
208 | result))))))
209 |
210 | #+sbcl
211 | (:method ((class sb-sys:system-area-pointer))
212 | (with-foreign-object (num-methods :int)
213 | (let ((methods (class-copy-method-list class num-methods)))
214 | (let ((result (list)))
215 | (dotimes (n (mem-aref num-methods :int) (nreverse result))
216 | (push (mem-aref methods :pointer n)
217 | result)))))))
218 |
219 | (defmethod get-methods (f)
220 | (list))
221 |
222 |
223 | (defun make-nsstring (str)
224 | [[#@NSString @(alloc)] @(initWithCString:encoding:) :string str :uint 4])
225 |
226 | (defun extract-nsstring (ns-str)
227 | [ns-str @(UTF8String)]s)
228 |
229 | (defun get-method-name (method)
230 | (sel-get-name (method-get-name method)))
231 |
232 | (defun get-method-names (thing)
233 | (mapcar (alexandria:compose #'sel-get-name
234 | #'method-get-name)
235 | (get-methods thing)))
236 |
237 | (defgeneric graph->dot (graph stream)
238 | (:method :around (graph stream)
239 | (declare (ignore graph))
240 | (format stream "~&digraph {~%~4trankdir=LR;~%")
241 | (call-next-method)
242 | (format stream "~&}"))
243 | (:method ((graph hash-table) stream)
244 | (loop for class being the hash-keys of graph using (hash-value superclass)
245 | do (format stream "~&~4t\"~a\" -> \"~a\"~%" class superclass))))
246 |
247 | (defparameter *selector-cache* (make-hash-table :test 'equal))
248 | (defparameter *class-cache* (make-hash-table :test 'equal))
249 |
250 | (serapeum:eval-always
251 | (defun normalize-selector-name (sel-name)
252 | (substitute #\: #\? sel-name)))
253 |
254 | (defun ensure-class (name)
255 | (let ((objc-class (objc-look-up-class name)))
256 | (when (and objc-class (not (null-pointer-p objc-class)))
257 | (alexandria:ensure-gethash name *class-cache* objc-class))))
258 |
259 | (defun ensure-selector (name)
260 | (alexandria:ensure-gethash name
261 | *selector-cache*
262 | (sel-register-name name)))
263 |
264 | (defmacro with-objc-classes ((&rest class-defs) &body body)
265 | `(let (,@(mapcar (fw.lu:destructuring-lambda ((lisp-name foreign-name))
266 | `(,lisp-name (objc-look-up-class ,foreign-name)))
267 | class-defs))
268 | ,@body))
269 |
270 |
271 |
272 | (cffi:defcvar (ns-app "NSApp" :library appkit) :pointer)
273 |
274 | (defclass objc-class ()
275 | ((%objc-class-name :initarg :name :reader name)
276 | (%class-pointer :initarg :pointer :reader class-pointer)
277 | (%cache :initform (make-hash-table :test 'equal) :allocation :class :reader objc-class-cache)))
278 |
279 | (defclass objc-selector ()
280 | ((%objc-selector-name :initarg :name :reader name)
281 | (%selector-pointer :initarg :pointer :reader selector-pointer)
282 | (%args :initarg :args :reader args)
283 | (%result-type :initarg :result-type :reader result-type)
284 | (%cache :initform (make-hash-table :test 'equal) :allocation :class :reader objc-selector-cache))
285 | (:metaclass closer-mop:funcallable-standard-class))
286 |
287 | (defun make-message-lambda-form (args rettype)
288 | (alexandria:with-gensyms ((target :target))
289 | (fw.lu:with (arg-syms (mapcar (serapeum:op _ (gensym "arg")) args))
290 | `(lambda (selector)
291 | (lambda (,target ,@arg-syms)
292 | (cffi:foreign-funcall
293 | "objc_msgSend"
294 | :pointer ,target
295 | :pointer selector
296 | ,@(mapcan #'list args arg-syms)
297 | ,rettype))))))
298 |
299 | (defmethod initialize-instance :after ((sel objc-selector) &key &allow-other-keys)
300 | (with-accessors ((pointer selector-pointer)
301 | (args args)
302 | (rettype result-type))
303 | sel
304 | (closer-mop:set-funcallable-instance-function
305 | sel
306 | (funcall (compile nil (make-message-lambda-form args rettype))
307 | pointer))))
308 |
309 | (defgeneric reset-class-cache (class)
310 | (:method ((class symbol))
311 | (reset-class-cache (find-class class)))
312 | (:method ((class class))
313 | (setf (slot-value (closer-mop:class-prototype class) '%cache)
314 | (make-hash-table :test 'equal))))
315 |
316 |
317 | (define-condition no-such-objc-class (serious-condition)
318 | ((%wanted-name :initarg :wanted-name :reader wanted-name))
319 | (:report (lambda (c s)
320 | (format s "No such Objective-C class: ~a" (wanted-name c)))))
321 |
322 | (defun %ensure-wrapped-objc-class (name)
323 | (let* ((class-cache (objc-class-cache (closer-mop:class-prototype (find-class 'objc-class))))
324 | (cached (gethash name class-cache)))
325 | (if cached
326 | cached
327 | (let ((objc-class (objc-look-up-class name)))
328 | (if (null-pointer-p objc-class)
329 | (error 'no-such-objc-class :wanted-name name)
330 | (setf (gethash name class-cache)
331 | (make-instance 'objc-class
332 | :name name
333 | :pointer objc-class)))))))
334 |
335 | ;; TODO: should this error if there is no corresponding selector?
336 | ;; Or should we let that fall through to message sending?
337 | (defun %ensure-wrapped-objc-selector (name target-class result-type args)
338 | (assert (= (count #\: name)
339 | (length args))
340 | (name args)
341 | "Invalid number of arg types for selector ~s" name)
342 |
343 | (let* ((class-cache (objc-selector-cache (closer-mop:class-prototype (find-class 'objc-selector))))
344 | (cached (gethash (list name target-class)
345 | class-cache)))
346 | (if cached
347 | cached
348 | (let ((objc-selector (ensure-selector name)))
349 | (setf (gethash (list name target-class) class-cache)
350 | (make-instance 'objc-selector
351 | :name name
352 | :pointer objc-selector
353 | :result-type result-type
354 | :args args))))))
355 |
356 | (defgeneric make-objc-instance (class &rest args)
357 | (:method ((class string) &rest args)
358 | (apply #'make-objc-instance (objc-look-up-class class) args))
359 | #+ccl
360 | (:method ((class ccl:macptr) &rest args)
361 | (declare (ignore args))
362 | (with-selectors (alloc init)
363 | [[class alloc] init]))
364 | #+sbcl
365 | (:method ((class sb-sys:system-area-pointer) &rest args)
366 | (declare (ignore args))
367 | (with-selectors (alloc init)
368 | [[class alloc] init])))
369 |
370 | (defun ensure-wrapped-objc-class (name)
371 | (tagbody
372 | retry (restart-case (return-from ensure-wrapped-objc-class
373 | (%ensure-wrapped-objc-class name))
374 | (use-value (new)
375 | :interactive (lambda ()
376 | (format t "New Objective-C class name: ")
377 | (multiple-value-list (read)))
378 | :report "Retry with new class name"
379 | (setf name new)
380 | (go retry)))))
381 |
382 | (defmacro with-selectors ((&rest selector-specs) &body body)
383 | `(let (,@(mapcar (fw.lu:destructuring-lambda ((sym foreign-selector))
384 | `(,sym (ensure-selector ,foreign-selector)))
385 | (mapcar (fwoar.anonymous-gf:glambda (spec)
386 | (:method ((spec symbol))
387 | (list spec (normalize-selector-name
388 | (string-downcase spec))))
389 | (:method ((spec cons))
390 | (list (car spec) (cadr spec))))
391 | selector-specs)))
392 | ,@body))
393 |
394 |
395 | (defmacro with-typed-selectors ((&rest defs) &body body)
396 | (let ((expanded-defs (loop for ((name objc-name) args ret-type) in defs
397 | collect
398 | `((,name (&rest r) (apply ,name r))
399 | (,name (%ensure-wrapped-objc-selector ,objc-name ',ret-type ',args))))))
400 | `(let (,@(mapcar #'second expanded-defs))
401 | (flet (,@(mapcar #'first expanded-defs))
402 | ,@body))))
403 |
404 | (defun description (nsobject)
405 | [nsobject @(description)]@)
406 |
407 | (defun future-ns-date (seconds)
408 | [[#@NSDate @(alloc)]
409 | @(initWithTimeIntervalSinceNow:)
410 | :double (coerce seconds 'double-float)])
411 |
412 | (defun tick-ns-runloop (run-loop &optional (time 0.5d0))
413 | (let ((date (future-ns-date time)))
414 | (unwind-protect [run-loop @(runUntilDate:)
415 | :pointer date]
416 | [date @(release)])))
417 |
--------------------------------------------------------------------------------
/demo-app.lisp:
--------------------------------------------------------------------------------
1 | (defpackage :demo-app
2 | (:use :cl :objc-runtime)
3 | (:export
4 | #:get-method-names))
5 | (in-package :demo-app)
6 | (named-readtables:in-readtable :objc-readtable)
7 |
8 | (cffi:defcallback exception-handler :void ((exception :pointer))
9 | (with-selectors (reason)
10 | (format t "~&Exxception: ~a~%" [exception reason])
11 | (values)))
12 |
13 | (defun init-window (window rect a b c)
14 | (format t "~&got rect: ~s" rect)
15 | (cffi:foreign-funcall "objc_msgSend"
16 | :pointer window
17 | :pointer @(initWithContentRect:)
18 | :pointer window
19 | (:struct objc-runtime::ns-rect) rect
20 | :char a
21 | :char b
22 | :boolean c
23 | :pointer))
24 |
25 | (defmacro selector-lambda (selector &rest args)
26 | `(lambda (receiver)
27 | [receiver ,selector ,@args]))
28 |
29 | (defun init-with-frame (thing rect)
30 | (format t "~&got rect: ~s" rect)
31 | (cffi:foreign-funcall "objc_msgSend"
32 | :pointer thing
33 | :pointer @(initWithFrame:)
34 | (:struct objc-runtime::ns-rect) rect
35 | :pointer))
36 |
37 |
38 | (cffi:defcfun (print-rect "printRect")
39 | :void
40 | (rect (:struct objc-runtime:ns-rect)))
41 |
42 | #+(or)
43 | (cffi:defcfun (set-uncaught-exception-handler "set_uncaught_exception_handler"
44 | :library objc-runtime::expose-stuff)
45 | :void
46 | (cb :pointer))
47 |
48 | (defun value-for-key (thing key)
49 | (with-selectors ((vfk "valueForKey:"))
50 | (let ((key (objc-runtime::make-nsstring key)))
51 | [thing vfk :string key])))
52 |
53 | (defun call-with-rect (x y w h cb)
54 | (check-type x real)
55 | (check-type y real)
56 | (check-type w real)
57 | (check-type h real)
58 | (cffi:with-foreign-object (rect '(:struct objc-runtime::ns-rect))
59 | (cffi:with-foreign-slots (((:pointer ns-rect-origin) (:pointer ns-rect-size))
60 | rect (:struct objc-runtime::ns-rect))
61 | (cffi:with-foreign-slots ((ns-point-x ns-point-y) ns-rect-origin (:struct ns-point))
62 | (setf ns-point-x (coerce x 'double-float)
63 | ns-point-y (coerce y 'double-float)))
64 | (cffi:with-foreign-slots ((ns-size-width ns-size-height)
65 | ns-rect-size (:struct ns-size))
66 | (setf ns-size-width (coerce w 'double-float)
67 | ns-size-height (coerce h 'double-float))))
68 | (funcall cb rect)))
69 |
70 | (defun call-with-point (x y cb)
71 | (check-type x real)
72 | (check-type y real)
73 | (cffi:with-foreign-object (point '(:struct ns-point))
74 | (cffi:with-foreign-slots ((ns-point-x ns-point-y) point (:struct ns-point))
75 | (setf ns-point-x (coerce x 'double-float)
76 | ns-point-y (coerce y 'double-float)))
77 | (funcall cb point)))
78 |
79 | (defmacro with-rect ((rect (x y) (w h)) &body body)
80 | `(call-with-rect ,x ,y ,w ,h
81 | (lambda (,rect)
82 | ,@body)))
83 |
84 | (defmacro with-point ((point (x y)) &body body)
85 | `(call-with-point ,x ,y
86 | (lambda (,point)
87 | ,@body)))
88 |
89 | (defun make-rect (x y w h)
90 | (check-type x real)
91 | (check-type y real)
92 | (check-type w real)
93 | (check-type h real)
94 | (cffi:convert-to-foreign `(ns-rect-origin
95 | (objc-runtime:ns-point-x
96 | ,(coerce x 'double-float)
97 | objc-runtime:ns-point-y
98 | ,(coerce y 'double-float))
99 | ns-rect-size
100 | (objc-runtime:ns-size-width
101 | ,(coerce w 'double-float)
102 | objc-runtime:ns-size-height
103 | ,(coerce h 'double-float)))
104 | '(:struct objc-runtime:ns-rect)))
105 |
106 | (defun show-alert (message &optional (informative-text "Informative Text!"))
107 | (let ((alert [[#@NSAlert @(alloc)] @(init)]))
108 | [alert @(setMessageText:) :pointer (objc-runtime::make-nsstring message)]
109 | [alert @(setInformativeText:) :pointer (objc-runtime::make-nsstring informative-text)]
110 | [alert @(addButtonWithTitle:) :pointer @"OK"]
111 | [alert @(addButtonWithTitle:) :pointer @"Cancel"]
112 | [alert @(runModal)]))
113 |
114 | (cffi:defcallback do-things-action :void ((a :pointer) (b :pointer) (sender :pointer))
115 | (declare (ignore a b sender))
116 | (show-alert "Starting Swank"
117 | "Loading Quicklisp from ~/quicklisp/setup.lisp + starting swank")
118 |
119 | (load "~/quicklisp/setup.lisp")
120 | (funcall (intern "QUICKLOAD" (find-package :QL)) :swank)
121 | (funcall (intern "CREATE-SERVER" (find-package :swank)) :port 5060 :dont-close t)
122 |
123 | (show-alert "Started swank on 5060"))
124 |
125 | (cffi:defcallback alert-action :void ((a :pointer) (b :pointer) (sender :pointer))
126 | (declare (ignore a b sender))
127 | (show-alert "Hello There!"))
128 |
129 | (cffi:defcallback profit-action :void ((a :pointer) (b :pointer) (sender :pointer))
130 | (declare (ignore a b sender))
131 | (show-alert "That Was Profitable!"))
132 |
133 | (defun alloc-init (cls)
134 | [[cls @(alloc)] @(init)])
135 |
136 | (defun make-button-delegate (button cb)
137 | (objc-runtime.data-extractors:objc-typecase button
138 | (#@NSButton (let ((my-class (objc-runtime::objc-allocate-class-pair #@NSObject "ButtonDel" 0)))
139 | (objc-runtime::class-add-method my-class @(doMagic) cb "v@:@")
140 | (fw.lu:prog1-bind (result (alloc-init my-class))
141 | [button @(setTarget:) :pointer result]
142 | [button @(setAction:) :pointer @(doMagic)])))
143 | (t (format t "~&The button is not a button~%"))))
144 |
145 | (defun make-app-delegate-class (outlets)
146 | (let ((app-delegate-class (objc-runtime::objc-allocate-class-pair
147 | #@NSObject "AppDelegate" 0)))
148 | (objc-runtime:add-pointer-ivar app-delegate-class "window")
149 | (objc-runtime:add-pointer-ivar app-delegate-class "delegate")
150 |
151 | (loop for outlet in outlets do
152 | (objc-runtime:add-pointer-ivar app-delegate-class outlet))
153 |
154 | app-delegate-class))
155 |
156 | (defun make-app-delegate-class-with-props (foo outlets)
157 | (let ((app-delegate-class (objc-runtime::objc-allocate-class-pair
158 | #@NSObject foo 0)))
159 | (objc-runtime:add-pointer-ivar app-delegate-class "window")
160 | (objc-runtime:add-pointer-ivar app-delegate-class "delegate")
161 |
162 | (loop for outlet in outlets do
163 | (objc-runtime:add-pointer-ivar app-delegate-class outlet))
164 |
165 | app-delegate-class))
166 |
167 |
168 | (defun load-nib (name)
169 | ;; find and activate the nib
170 | (let* ((bundle [#@NSBundle @(mainBundle)])
171 | (nib [[#@NSNib @(alloc)] @(initWithNibNamed:bundle:)
172 | :pointer (objc-runtime::make-nsstring name)
173 | :pointer bundle]))
174 | (cffi:with-foreign-object (p :pointer)
175 | ;; TODO: is dropping p a problem here? The docs say something relevant.
176 | ;; must investigate.
177 | [nib @(instantiateWithOwner:topLevelObjects:)
178 | :pointer objc-runtime::ns-app
179 | :pointer p])))
180 |
181 | ;#+null
182 | (defun main ()
183 | #+sbcl
184 | (sb-int:set-floating-point-modes :traps '())
185 |
186 | (load "~/quicklisp/setup.lisp")
187 | (funcall (intern "QUICKLOAD"
188 | (find-package :QL))
189 | :swank)
190 |
191 | #+nil
192 | (funcall (intern "CREATE-SERVER"
193 | (find-package :swank))
194 | :port 5060
195 | :dont-close t)
196 |
197 | (trivial-main-thread:with-body-in-main-thread (:blocking t)
198 | [#@NSAutoreleasePool @(new)]
199 | [#@NSApplication @(sharedApplication)]
200 | #+nil
201 | [objc-runtime::ns-app @(setActivationPolicy:) :int 0]
202 |
203 | ;; Setup the app delegate class. We register this one because it's useful
204 | ;; When debugging via something like lldb
205 | (objc-runtime::objc-register-class-pair
206 | (make-app-delegate-class '("actionButton"
207 | "alertButton"
208 | "profitButton")))
209 |
210 | (load-nib "MainMenu.nib")
211 |
212 | (let ((app-delegate [objc-runtime::ns-app @(delegate)]))
213 | (make-button-delegate (value-for-key app-delegate "actionButton")
214 | (cffi:callback do-things-action))
215 | (make-button-delegate (value-for-key app-delegate "alertButton")
216 | (cffi:callback alert-action))
217 | (make-button-delegate (value-for-key app-delegate "profitButton")
218 | (cffi:callback profit-action)))
219 |
220 | [objc-runtime::ns-app @(activateIgnoringOtherApps:) :boolean t]
221 | [objc-runtime::ns-app @(run)]))
222 |
223 | (defclass application-shim ()
224 | ((%main-view :initarg :main-view :accessor main-view)))
225 |
226 | (cffi:defcfun (%set-string-value "objc_msgSend")
227 | :void
228 | (cls objc-runtime::o-class)
229 | (sel objc-runtime::o-selector)
230 | (value :pointer))
231 |
232 | (defun set-string-value (control string)
233 | (prog1 control
234 | (%set-string-value control @(setStringValue:)
235 | (objc-runtime:make-nsstring string))))
236 |
237 | (defun label (text)
238 | (let ((view [[#@NSTextField @(alloc)] @(init)]))
239 | (prog1 view
240 | (set-string-value view text))))
241 |
242 | (defun button (title)
243 | (trivial-main-thread:with-body-in-main-thread (:blocking t)
244 | [#@NSButton @(buttonWithTitle:target:action:)
245 | :pointer (objc-runtime:make-nsstring title)
246 | :pointer #@NSButton
247 | :pointer @(alloc)]))
248 |
249 | (defun init-in-main-thread (instance)
250 | (prog1 instance
251 | [instance @(performSelectorOnMainThread:withObject:waitUntilDone:)
252 | :pointer @(init)
253 | :pointer (cffi:null-pointer)
254 | :bool t]))
255 |
256 | (defvar *application-shim*
257 | (make-instance 'application-shim))
258 | (defun wait-for-events ()
259 | (let ((event [objc-runtime::ns-app @(nextEventMatchingMask:untilDate:inMode:dequeue:)
260 | :unsigned-long 18446744073709551615
261 | :pointer [#@NSDate @(distantFuture)]
262 | :pointer @"kCFRunLoopDefaultMode"
263 | :int 1]))
264 | [objc-runtime::ns-app @(sendEvent:) :pointer event]
265 | event))
266 |
267 | (defun tick ()
268 | (wait-for-events))
269 |
270 | (defun task-thread ()
271 | (bt:make-thread (lambda ()
272 | #+(or)
273 | (trivial-main-thread:with-body-in-main-thread (:blocking t)
274 | [#@NSEvent @(stopPeriodicEvents)]
275 | [#@NSEvent @(startPeriodicEventsAfterDelay:withPeriod:) :double 0.0d0 :double 0.01d0])
276 | (loop
277 | (trivial-main-thread:with-body-in-main-thread (:blocking t)
278 | (tick))))
279 | :name "Cocoa Event Loop Feeder"))
280 |
281 | ;;#+nil
282 | (defun old-main ()
283 | (trivial-main-thread:with-body-in-main-thread (:blocking nil)
284 | #+sbcl
285 | (sb-int:set-floating-point-modes :traps '())
286 |
287 | [#@NSAutoreleasePool @(new)]
288 | [#@NSApplication @(sharedApplication)]
289 |
290 | (format t "~&app: ~s~%" objc-runtime::ns-app)
291 | #+nil
292 | [objc-runtime::ns-app @(setActivationPolicy) :int 0]
293 |
294 | (let* ((application-name [[#@NSProcessInfo @(processInfo)] @(processName)]))
295 | (let* ((menubar [[#@NSMenu @(new)] @(autorelease)])
296 | (app-menu-item [[#@NSMenuItem @(new)] @(autorelease)])
297 | (app-menu [[#@NSMenu @(new)] @(autorelease)])
298 | (quit-name @"Quit")
299 | (key @"q")
300 | (quit-menu-item
301 | [[[#@NSMenuItem @(alloc)]
302 | @(initWithTitle:action:keyEquivalent:) :pointer quit-name :pointer @(terminate?) :string key]
303 | @(autorelease)]))
304 | [menubar @(addItem:) :pointer app-menu-item]
305 | [app-menu @(addItem:) :pointer quit-menu-item]
306 | [app-menu-item @(setSubmenu:) :pointer app-menu]
307 | [objc-runtime::ns-app @(setMainMenu:) :pointer menubar] )
308 |
309 | (setf (main-view *application-shim*)
310 | [#@NSStackView @(stackViewWithViews:)
311 | :pointer [[#@NSArray @(alloc)] @(init)]])
312 | (with-point (p (20 20))
313 | (let* ((foreign-rect (make-rect 10 10 120 120))
314 | (the-window (init-window [#@NSWindow @(alloc)] foreign-rect 15 2 nil)))
315 |
316 | [(value-for-key the-window "contentView") @(addSubview:) :pointer (main-view *application-shim*)]
317 | [the-window @(cascadeTopLeftFromPoint:) :pointer p]
318 | [the-window @(setTitle:) :pointer application-name]
319 | [the-window @(makeKeyAndOrderFront:) :pointer (cffi:null-pointer)]
320 | [ objc-runtime::ns-app @(activateIgnoringOtherApps:) :boolean t]
321 | (task-thread))))))
322 |
323 | (cffi:defcfun (%get-view-frame "objc_msgSend_stret")
324 | :void
325 | (out (:pointer (:struct objc-runtime:ns-rect)))
326 | (class :pointer)
327 | (sel :pointer))
328 |
329 | (cffi:defcfun (%init-with-frame "objc_msgSend")
330 | :pointer
331 | (class :pointer)
332 | (sel :pointer)
333 | (frame (:struct objc-runtime:ns-rect)))
334 |
335 | (defmacro new-msg-send (selector ((&rest arg-types) return-type))
336 | (let ((arg-syms (mapcar (lambda (_) (gensym (symbol-name _)))
337 | arg-types)))
338 | `(lambda ,(cons 'target arg-syms)
339 | (cffi:foreign-funcall "objc_msgSend"
340 | :pointer target
341 | :pointer ,selector
342 | ,@(mapcan #'list arg-types arg-syms)
343 | ,return-type))))
344 |
345 | (defmacro make-view-dictionary (&rest objc-values)
346 | (alexandria:with-gensyms (selector)
347 | `(let ((,selector (new-msg-send @(dictionaryWithObjectsAndKeys:)
348 | ((,@(mapcar (lambda (_) _ :pointer) objc-values) :pointer)
349 | :pointer))))
350 | (funcall ,selector ,@objc-values (cffi:null-pointer)))))
351 |
352 | #+(or)
353 | (defun text-view (parent-view)
354 | (let ((text-view [#@NSTextView @(alloc)]))
355 |
356 |
357 |
358 |
359 |
360 | (trivial-main-thread:with-body-in-main-thread (:blocking nil)
361 | (cffi:with-foreign-pointer (v (cffi:foreign-type-size '(:struct objc-runtime::ns-rect)))
362 | (%get-view-frame v *window-view* @(frame))
363 | (init-with-frame *text-view* v))
364 | [*window-view* @(addSubview:) :pointer *text-view*]?)
365 |
366 | (defparameter *view-dictionary*
367 | )
368 | ))
369 |
370 | #+(or)
371 | (progn
372 | (defparameter *window-view*
373 | [(main-view *application-shim*) @(superview)])
374 | (trivial-main-thread:with-body-in-main-thread (:blocking nil)
375 | [(main-view *application-shim*) @(removeFromSuperview)]?
376 | ))
377 |
--------------------------------------------------------------------------------
/MainMenu.xib:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 |
19 |
20 |
21 |
22 |
23 |
24 |
686 |
692 |
693 |
694 |
695 |
696 |
697 |
698 |
699 |
700 |
701 |
708 |
718 |
725 |
726 |
727 |
728 |
729 |
730 |
731 |
732 |
733 |
734 |
735 |
736 |
737 |
738 |
739 |
740 |
741 |
742 |
743 |
744 |
745 |
--------------------------------------------------------------------------------