blob: 028d722aad18326582da389fa4f4e2667fc9d046 (
plain)
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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
;;;; Objective-CL, an Objective-C bridge for Common Lisp.
;;;; Copyright (C) 2007 Matthias Andreas Benkard.
;;;;
;;;; This program is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public License
;;;; as published by the Free Software Foundation, either version 3 of
;;;; the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful, but
;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this program. If not, see
;;;; <http://www.gnu.org/licenses/>.
(in-package #:mulk.objective-cl)
;;; (@* "Message and selector names")
(defun message-component->string (symbol)
(let ((case-converted-name
(name-hyphenated->mixed-case (symbol-name symbol) :camel-case)))
(if (eql (find-package '#:keyword)
(symbol-package symbol))
(concatenate 'string case-converted-name ":")
case-converted-name)))
(defun symbol-list->message-name (symbol-list)
(reduce #'(lambda (acc symbol)
(concatenate 'string acc (message-component->string symbol)))
symbol-list
:initial-value ""))
(defun generic-function-name->method-name (gf-name)
(symbol-name gf-name))
(defun generic-function-name->selector (gf-name)
(selector (symbol-name gf-name)))
;;; (@* "Class names")
(defun symbol->objc-class-name (symbol)
(let* ((name (symbol-name symbol))
(hyphen-pos (position #\- name))
(head (if hyphen-pos
(subseq name 0 hyphen-pos)
nil))
(tail (if hyphen-pos
(subseq name hyphen-pos)
name))
(converted-tail
(name-hyphenated->mixed-case tail :nerd-caps)))
(if head
(concatenate 'string
(string-upcase head)
converted-tail)
converted-tail)))
(defun export-and-return (symbol)
(export (list symbol))
symbol)
(define-cached-function objc-class-name->symbol (class-name) class-name
(let* ((prefix-end+1 (position-if #'lower-case-p class-name))
(prefix-end (and prefix-end+1 (1- prefix-end+1))))
(cond ((and prefix-end (> prefix-end 0))
;; There are n upper case chars at the head of the name.
;; Take the first (1- n) of them and downcase them. Then,
;; put a dash right after them and downcase the n'th char as
;; well, such that "NSFoo" becomes "ns-foo".
(setq class-name (concatenate 'string
(string-downcase
(subseq class-name 0 prefix-end))
"-"
(string
(char-downcase
(char class-name prefix-end)))
(subseq class-name (1+ prefix-end)))))
((and prefix-end (zerop prefix-end))
;; There is exactly one upper case char at the head of the
;; name. just downcase it and move on.
(setq class-name (copy-seq class-name))
(setf (char class-name 0) (char-downcase (char class-name 0))))))
(loop for delim-position = (position-if #'upper-case-p class-name)
while delim-position
do (setq class-name (concatenate 'string
(subseq class-name 0 delim-position)
"-"
(string
(char-downcase
(char class-name delim-position)))
(subseq class-name (1+ delim-position)))))
(let ((*package* (find-package '#:objective-c-classes)))
;; Why do we use READ-FROM-STRING rather than MAKE-SYMBOL? That is
;; because we want this procedure to work as expected for any value
;; of (READTABLE-CASE *READTABLE*), which means that 'ns-object
;; should always mean the same thing as "NSObject".
(export-and-return
(read-from-string class-name))))
(defun objc-meta-class-name->symbol (meta-class-name)
(let ((*package* (find-package '#:objective-c-classes)))
(export-and-return
(intern
(concatenate 'string
"+"
(symbol-name (objc-class-name->symbol meta-class-name)))))))
(defun objc-fake-meta-class-name->symbol (meta-class-name)
(let ((*package* (find-package '#:objective-c-classes)))
(export-and-return
(intern
(concatenate 'string
"++"
(symbol-name (objc-class-name->symbol meta-class-name)))))))
(defun name-hyphenated->mixed-case (string &optional (case-convention :nerd-caps))
(let ((lower-case-string (name->canonised-lower-case string)))
(ecase case-convention
((:camel-case) (name-hyphenated->camel-case lower-case-string))
((:nerd-caps) (name-hyphenated->nerd-caps lower-case-string))
((:underscored) (name-hyphenated->underscored lower-case-string))
((:hyphenated) lower-case-string))))
(defun slot-name->foreign-slot-name (slot-name
&key (case-convention :camel-case))
(name-hyphenated->mixed-case (symbol-name slot-name) case-convention))
(defun foreign-slot-name->slot-name (foreign-slot-name)
(let ((*package* (find-package '#:objective-c-classes)))
(export-and-return (read-from-string (name-underscored->hyphenated
(name-camel-case->hyphenated
foreign-slot-name))))))
(defun name-underscored->hyphenated (string)
(substitute #\- #\_ string))
(defun name-hyphenated->underscored (string)
(substitute #\_ #\- string))
(defun name->canonised-lower-case (string)
(cond ((name-in-canonical-case-p string) (string-downcase string))
((and (member (readtable-case *readtable*) '(:upcase :invert))
(notany #'upper-case-p string))
(string-upcase string))
(t string)))
(defun name-in-canonical-case-p (string
&optional
(case-mode (readtable-case *readtable*)))
(or (and (member case-mode '(:downcase :preserve))
(notany #'upper-case-p string))
(and (member case-mode '(:upcase :invert))
(notany #'lower-case-p string))))
(defun string-capitalise-lower-case (string)
"Like STRING-CAPITALIZE except that all upper-case characters are left alone."
(with-output-to-string (out)
(loop for previous-position = 0 then word-start
for delimiter-pos = (position-if-not #'alphanumericp
string
:start previous-position)
for word-start = (and delimiter-pos (1+ delimiter-pos))
do (format out
"~:(~C~)~A"
(char string previous-position)
(subseq string
(1+ previous-position)
(or word-start (length string))))
while word-start)))
(defun name-hyphenated->camel-case (string)
(remove #\- (concatenate 'string
(string (char string 0))
(subseq (string-capitalise-lower-case string) 1))))
(defun name-camel-case->hyphenated (string)
(with-output-to-string (out)
(loop for previous-position = 0 then word-start
for word-start = (position-if #'upper-case-p
string
:start (1+ previous-position))
do (format out "~(~A~)" (subseq string
previous-position
(or word-start (length string))))
while word-start
do (format out "-"))))
(defun name-hyphenated->nerd-caps (string)
(remove #\- (string-capitalise-lower-case string)))
|
