-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathobjc-data-extractors.lisp
127 lines (109 loc) · 4.23 KB
/
objc-data-extractors.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
;; objc-data-extractor.lisp
;; [[file:~/git_repos/objc-lisp-bridge/README.org::*objc-data-extractor.lisp][objc-data-extractor.lisp:1]]
(defpackage :objc-runtime.data-extractors
(:use :cl )
(:export
#:extract-from-objc
#:define-extractor
#:clear-extractors
#:add-extractor
#:get-plist
#:objc-typecase))
(in-package :objc-runtime.data-extractors)
(named-readtables:in-readtable :objc-readtable)
(defun get-plist (file)
[#@NSDictionary @(dictionaryWithContentsOfFile:)
:pointer (objc-runtime::make-nsstring file)])
(defun objc-subclass-p (sub super)
(unless (or (cffi:null-pointer-p sub)
(cffi:null-pointer-p super))
(or (eql sub super)
(= [sub @(isSubclassOfClass:) :pointer [super @(class)]]#
1))))
(defun order-objc-classes (classes &rest r &key key)
(declare (ignore key))
(apply 'stable-sort
(copy-seq classes)
'objc-subclass-p
r))
(defun objc-isa (obj class)
(unless (or (cffi:null-pointer-p obj)
(cffi:null-pointer-p class))
(= [obj @(isKindOfClass:) :pointer class]#
1)))
(defun objc-pick-by-type (obj pairs)
(assoc obj
(order-objc-classes pairs :key 'car)
:test 'objc-isa))
(serapeum:eval-always
(defun make-cases (cases obj)
(mapcar (serapeum:op
`(if (objc-isa ,obj ,(car _1))
(progn ,@(cdr _1))))
cases)))
(defmacro objc-typecase (form &body ((case-type &body case-handler) &rest cases))
(alexandria:once-only (form)
(let* ((initial-cases `((,case-type ,@case-handler) ,@(butlast cases)))
(cases (fw.lu:rollup-list (make-cases initial-cases form)
(if (eql t (caar (last cases)))
`((progn ,@(cdar (last cases))))
(make-cases (last cases) form)))))
cases)))
(defun map-nsarray (fn arr)
(unless (and (cffi:pointerp arr)
(objc-isa arr #@NSArray))
(error "must provide a NSArray pointer"))
(loop for x below [arr @(count)]#
collect (funcall fn [arr @(objectAtIndex:) :int x])))
(defun nsarray-contents (arr)
(unless (and (cffi:pointerp arr)
(objc-isa arr #@NSArray))
(error "must provide a NSArray pointer"))
(dotimes (n [arr @(count)]#)
(let ((obj [arr @(objectAtIndex:) :int n ]))
(objc-typecase obj
(#@NSString (format t "~&string~%"))
(#@NSArray (format t "~&array~%"))
(#@NSDictionary (format t "~&dictionary~%"))
(t (format t "~&other... ~s~%" (objc-runtime::objc-class-get-name
(objc-runtime::object-get-class obj))))))))
(defmacro funcall-some (fun &rest args)
(alexandria:once-only (fun)
`(if ,fun
(funcall ,fun ,@args))))
(defvar *objc-extractors* (list)
"Functions called to extract specific data types")
(defun extract-from-objc (obj)
(objc-typecase obj
(#@NSDate [[[[#@NSISO8601DateFormatter @(alloc)]
@(init)]
@(stringFromDate:) :pointer obj]
@(UTF8String)]s)
(#@NSString [obj @(UTF8String)]s)
(#@NSNumber (parse-number:parse-number
(objc-runtime::extract-nsstring
[obj @(stringValue)])))
(#@NSArray (map-nsarray #'extract-from-objc obj))
(#@NSDictionary (fw.lu:alist-string-hash-table
(pairlis (map-nsarray #'extract-from-objc [obj @(allKeys)])
(map-nsarray #'extract-from-objc [obj @(allValues)]))))
(t (or (funcall-some (cdr (objc-pick-by-type obj *objc-extractors*))
obj)
obj))))
(defmacro define-extractor (class (o) &body body)
`(serapeum:eval-always
(add-extractor ,class
(lambda (,o)
,@body))
*objc-extractors*))
(defun clear-extractors ()
(setf *objc-extractors* ()))
(serapeum:eval-always
(defun add-extractor (class cb)
(unless (member class *objc-extractors* :test 'cffi:pointer-eq :key #'car)
(setf *objc-extractors*
(merge 'list *objc-extractors* (list (cons class cb))
'objc-subclass-p
:key 'car)))
*objc-extractors*))
;; objc-data-extractor.lisp:1 ends here