-
-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathmacos.lisp
174 lines (147 loc) · 6.91 KB
/
macos.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
(in-package #:org.shirakumo.file-select.macos)
(cffi:define-foreign-library cocoa
(t (:framework "Cocoa")))
(cffi:define-foreign-library appkit
(t (:framework "AppKit")))
(cffi:define-foreign-library foundation
(t (:framework "Foundation")))
(set 'cl-user::*foreign-system-libraries*
(union (when (boundp 'cl-user::*foreign-system-libraries*)
(symbol-value 'cl-user::*foreign-system-libraries*))
'(cocoa appkit foundation)))
(defclass macos (backend)
())
(defmethod initialize-instance :after ((backend macos) &key)
(unless (cffi:foreign-library-loaded-p 'cocoa)
(cffi:use-foreign-library foundation)
(cffi:use-foreign-library cocoa)
(cffi:use-foreign-library appkit)))
(defmethod new-with ((backend macos) &rest args)
(apply #'open* "NSSavePanel" "savePanel" args))
(defmethod existing-with ((backend macos) &rest args)
(apply #'open* "NSOpenPanel" "openPanel" args))
(cffi:defctype size_t #+x86-64 :uint64 #+x86 :uint32 #-(or x86-64 x86) :long)
(cffi:defctype id :pointer)
(cffi:defctype oclass :pointer)
(cffi:defctype sel :pointer)
(cffi:defcfun (get-class "objc_getClass") oclass
(name :string))
(cffi:defcfun (register-name "sel_registerName") sel
(name :string))
(cffi:defcfun (set-uncaught-exception-handler "NSSetUncaughtExceptionHandler") :void
(handler :pointer))
(cffi:defcallback exception-handler :void ((object id) (pointer :pointer))
(error "Fuck!"))
(defmacro objc-call (self method &rest args)
(when (stringp self)
(setf self `(get-class ,self)))
(when (evenp (length args))
(setf args (append args '(id))))
(let* ((struct (gensym "STRUCT"))
(retval (car (last args)))
(base-args (list* 'id self
'sel `(register-name ,method)
(loop for (type name) on (butlast args) by #'cddr
collect `,type collect name))))
(cond ((and (listp retval) (eq :struct (first retval)))
`(cffi:with-foreign-object (,struct ',retval)
(cffi:foreign-funcall "objc_msgSend_stret" :pointer ,struct ,@base-args :void)
(cffi:mem-ref ,struct ',retval)))
((find retval '(:double :float))
`(cffi:foreign-funcall "objc_msgSend_fpret" ,@base-args ,retval))
(T
`(cffi:foreign-funcall "objc_msgSend" ,@base-args ,retval)))))
(defun free-instance (id)
(objc-call id "dealloc" :void))
(defmacro with-object ((var init) &body body)
`(let ((,var ,init))
(unwind-protect
(progn ,@body)
(free-instance ,var))))
(cffi:defcenum NSApplicationActivationPolicy
(:regular 0)
(:accessory 1)
(:prohibited 2))
(cffi:defcenum NSModalResponse
(:cancel 0)
(:ok 1))
(cffi:defcenum NSWindowStyleMask
(:borderless 0)
(:titled 1)
(:closable 2)
(:miniaturizable 4)
(:resizable 8)
(:utility-window 16)
(:doc-modal-window 32)
(:non-activating-panel 64)
(:unified-title-and-toolbar 4096)
(:full-screen 16384)
(:full-size-content-view 32768)
(:hud-window 8192))
(cffi:defcenum NSBackingStoreType
(:buffered 2))
(cffi:defcvar (nsapp "NSApp") :pointer)
(cffi:defcenum (NSEventMask :uint64)
(:any #.(1- (ash 1 64))))
(cffi:defcvar (nsdefaultrunloopmode "NSDefaultRunLoopMode") :pointer)
(defun ensure-url-path (url filter)
(let ((string (objc-call url "fileSystemRepresentation" :string)))
(when (eq filter :directory)
(setf string (format NIL "~a/" string)))
(parse-native-namestring string)))
(defun process-event (app)
(let ((event (objc-call app "nextEventMatchingMask:untilDate:inMode:dequeue:"
NSEventMask :any
:pointer (objc-call "NSDate" "distantPast")
:pointer nsdefaultrunloopmode
:bool T)))
(unless (cffi:null-pointer-p event)
(objc-call app "sendEvent:" :pointer event))))
(defmacro with-body-in-main-thread (args &body body)
#+darwin `(trivial-main-thread:with-body-in-main-thread ,args ,@body)
#-darwin `(progn ,@body))
(defun open* (class constructor &key title default filter multiple message backend)
(declare (ignore backend))
(with-body-in-main-thread (:blocking T)
(float-features:with-float-traps-masked T
(let ((strings ()))
(unwind-protect
(flet ((nsstring (string)
(car (push (objc-call "NSString" "stringWithUTF8String:" :string string) strings))))
(set-uncaught-exception-handler (cffi:callback exception-handler))
(let ((app (objc-call "NSApplication" "sharedApplication")))
(objc-call app "setActivationPolicy:" NSApplicationActivationPolicy :accessory :bool)
(with-object (window (objc-call (get-class class) constructor))
(objc-call window "setTitle:" :pointer (nsstring title))
(when message
(objc-call window "setMessage:" :pointer (nsstring message)))
(objc-call window "setAllowsMultipleSelection:" :bool multiple)
(objc-call window "setCanChooseDirectories:" :bool (eq filter :directory))
(objc-call window "setCanChooseFiles:" :bool (not (eq filter :directory)))
(when default
(objc-call window "setNameFieldStringValue:" :pointer (nsstring (file-namestring default)))
(with-object (url (objc-call "NSURL" "URLWithString:" :pointer (nsstring (native-namestring default))))
(objc-call window "setDirectoryURL:" :pointer url)))
(when (stringp filter)
(setf filter `(("" ,filter))))
(when (consp filter)
(cffi:with-foreign-object (list :pointer (length filter))
(loop for i from 0
for (name type) in filter
do (setf (cffi:mem-aref list :pointer i) (nsstring type)))
(with-object (array (objc-call "NSArray" "arrayWithObjects:count:" :pointer list :uint (length filter)))
(objc-call window "setAllowedFileTypes:" :pointer array))))
(ecase (unwind-protect (objc-call window "runModal" NSModalResponse)
;; This is necessary to get the window to close.
(loop while (process-event app)))
(:cancel (values NIL NIL))
(:ok
(values
(if multiple
(let ((urls (objc-call window "URLs")))
(loop for i from 0 below (objc-call urls "count" :uint)
for url = (objc-call urls "objectAtIndex:" :uint i)
collect (ensure-url-path url filter)))
(ensure-url-path (objc-call window "URL") filter))
T))))))
(mapc #'free-instance strings))))))