-
Notifications
You must be signed in to change notification settings - Fork 0
/
nsymbols.lisp
195 lines (169 loc) · 8.18 KB
/
nsymbols.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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
;;;; SPDX-License-Identifier: BSD-3-Clause
(in-package #:nsymbols)
(define-condition multiple-resolved-symbols-error (error)
((designator :initarg :designator
:accessor designator)
(results :initarg :results
:accessor results))
(:report (lambda (condition stream)
(format stream "Multiple ~a symbols found:"
(designator condition))
(dolist (result (results condition))
(terpri stream)
(prin1 result stream))))
(:documentation "Raised when `resolve-symbol' finds multiple symbols with `error-p' set to T."))
(export 'multiple-resolved-symbols-error)
(deftype symbol-visibility ()
`(member :internal :external :inherited :any))
(deftype string-designator ()
`(or string symbol))
;; Basically a copy of `trivial-types:package-designator', but without characters.
(deftype package-designator ()
`(or string-designator package))
(declaim (ftype (function (symbol) symbol-visibility)
symbol-visibility))
(defun symbol-visibility (symbol)
"Return the visibility of a symbol as one of :internal, :external, or :inherited."
(nth-value 1 (find-symbol (symbol-name symbol) (symbol-package symbol))))
(export 'symbol-visibility)
(declaim (ftype (function (symbol-visibility list) list)
filter-symbols))
(defun filter-symbols (visibility symbols)
"Filter SYMBOLS by VISIBILITY.
If visibility is :any, all symbols are accepted."
(if (eq visibility :any)
symbols
(remove-if-not (lambda (s) (eq visibility (symbol-visibility s)))
symbols)))
(export 'filter-symbols)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *symbol-types* (make-hash-table :test 'equalp)
"The table from the name of the symbol type (as a symbol name string)
to the predicate of this type as a function symbol."))
(deftype symbol-type (type)
(let ((type-name (string type)))
(if (gethash type-name *symbol-types*)
`(satisfies ,(gethash type-name *symbol-types*))
(error "There's no such symbol type: ~a" type))))
(declaim
(ftype (function ((or list package-designator)
&key (:visibility symbol-visibility)
(:type string-designator))
(values list &optional))
package-symbols))
(defun package-symbols (packages &key (visibility :any) (type :any))
"Return the list of all symbols from PACKAGES.
If VISIBILITY is specified, only include symbols with that visibility.
If TYPE is specified, only include symbols of that type.
PACKAGES can be a single package designator or a list of package designators.
VISIBILITY can be one of :ANY, :INTERNAL, :EXTERNAL, or :INHERITED."
(let* ((packages (uiop:ensure-list packages))
(symbols
(delete-if-not
(symbol-function (gethash (string type) *symbol-types*))
(loop for package in (mapcar #'find-package packages)
append
(if (eq :external visibility)
(loop for s being the external-symbol in package
collect s)
(loop for s being the symbol in package
when (eq (symbol-package s) package)
collect s))))))
(case visibility
((:any :external)
symbols)
((:internal :inherited)
(filter-symbols visibility symbols)))))
(export 'package-symbols)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar %symbol% nil
"Special variable to bind symbols during type-checking to.")
(export '%symbol%))
(defmacro define-symbol-type (name (&rest parents) &body predicate-body)
"Define a new symbol type.
Generates several functions and exports them out of :nsymbols package
for convenience (%NAME% is substituted with NAME):
- %NAME%-SYMBOL-P -- a predicate checking the symbol for being of this type.
- %NAME%-SYMBOL -- a type to check the symbol.
- PACKAGE-%NAME%S -- a configurable package symbol listing.
In other words, it generates VARIABLE-SYMBOL-P, VARIABLE-SYMBOL, and
PACKAGE-VARIABLES for VARIABLE symbol type.
NAME is a symbol designator to reference this symbol type in
`resolve-symbol', or a list of two symbol designators:
- First symbol designator is the symbol type name.
- Second designator is its plural version, if atypical.
PREDICATE-BODY is the body of the boolean-returning function to find
the required symbols among the list of other symbols. You can refer to
the symbol being checked with a special variable %SYMBOL%."
(let* ((proper-name (string (if (listp name)
(first name)
name)))
(plural-name (if (listp name)
(string (second name))
(uiop:strcat proper-name "S")))
(predicate-name (intern (uiop:strcat proper-name "-SYMBOL-P") :nsymbols))
(type-name (intern (uiop:strcat proper-name "-SYMBOL") :nsymbols))
(package-operation-name (intern (uiop:strcat "PACKAGE-" plural-name) :nsymbols)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ,predicate-name (%symbol%)
,(format nil "Auto-generated predicate for symbol type ~a" proper-name)
(and (symbolp %symbol%)
,@predicate-body))
(setf (gethash ,proper-name *symbol-types*)
(quote ,predicate-name))
(deftype ,type-name ()
,(format nil "Auto-generated type definition for symbol type ~a" proper-name)
(quote (and ,@(loop for parent in parents
collect `(symbol-type ,parent))
(satisfies ,predicate-name))))
(defun ,package-operation-name (packages &optional (visibility :any))
,(format nil "Auto-generated package lister for symbol type ~a" proper-name)
(package-symbols packages :visibility visibility :type ,proper-name))
(export (quote ,predicate-name) :nsymbols)
(export (quote ,type-name) :nsymbols)
(export (quote ,package-operation-name) :nsymbols))))
(export 'define-symbol-type)
;; Recognize :ANY/"ANY"/'ANY in `package-symbols' and `resolve-symbol'.
(setf (gethash "ANY" *symbol-types*) 'identity)
(define-symbol-type variable ()
(boundp %symbol%))
(define-symbol-type function ()
(fboundp %symbol%))
(define-symbol-type generic-function (function)
(typep (ignore-errors (symbol-function %symbol%)) 'standard-generic-function))
(define-symbol-type macro (function)
(macro-function %symbol%))
;; FIXME: make "class" an umbrella for structures + "actual classes"?
;; How do we call "actual classes" then?
(define-symbol-type (class classes) ()
(and (find-class %symbol% nil)
(typep (find-class %symbol%) 'standard-class)))
(define-symbol-type structure ()
(and (find-class %symbol% nil)
(typep (find-class %symbol%) 'structure-class)))
(defvar *default-packages* '(:cl :cl-user)
"Package designator or a list of package designators for `resolve-symbol' to use by default.")
(export '*default-packages*)
(declaim
(ftype (function (string-designator string-designator &optional (or package-designator (cons package-designator *)) boolean)
(values symbol list &optional))
resolve-symbol))
(defun resolve-symbol (designator type &optional (packages *default-packages*) error-p)
"Find the symbol (of symbol type TYPE) designated by DESIGNATOR in PACKAGES (and subpackages).
PACKAGES should be a package designator or a list thereof.
ERROR-P, when present and true, raises a continuable error of type
`multiple-resolved-symbols-error' if there is more than one symbol
found matching the DESIGNATOR."
(let* ((packages (uiop:ensure-list packages))
(designator (string designator))
(symbols (package-symbols packages :type type)))
(let* ((results (remove-if-not (lambda (sym) (string= designator (symbol-name sym)))
symbols)))
(cond
((and (> (length results) 1) error-p)
(cerror "Proceed with the first matching symbol" 'multiple-resolved-symbols-error
:designator designator :symbols results)))
(values (first results)
results))))
(export 'resolve-symbol)