forked from jaeschliman/com.clearly-useful.nick
-
Notifications
You must be signed in to change notification settings - Fork 0
/
com.clearly-useful.nick.lisp
100 lines (82 loc) · 2.73 KB
/
com.clearly-useful.nick.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
;;;; com.clearly-useful.nick.lisp
(in-package #:com.clearly-useful.nick)
(defun all-package-names ()
(loop for package in (list-all-packages)
appending (cons (package-name package)
(package-nicknames package))))
(defun package-name-available-p (nick)
(member (string nick) (all-package-names) :test 'string=))
(defun state-of-the-world ()
(loop for package in (list-all-packages)
collect (list package (package-name package)
(package-nicknames package))))
(defun package-state (package)
(list (package-name package)
(package-nicknames package)))
(defun %augment-package-state (state nick)
(list (first state)
(cons nick (second state))))
(defun set-package-state (package state)
(let (
#+allegro
(excl:*enable-package-locked-errors* nil)
(locked (package-locked-p package)))
(when locked (unlock-package package))
(unwind-protect
(if (not (null (cadr state)))
(rename-package package (first state) (cadr state))
(rename-package package (first state)))
(when locked (lock-package package)))
))
(defun package-state-equal-p (a b)
(and (string= (first a) (first b))
(null (set-difference (cadr a) (cadr b) :test 'string=))
(null (set-difference (cadr b) (cadr a) :test 'string=))))
(defun %set-world-state (state)
(loop for (package . package-state) in state
do (set-package-state package package-state)))
(defun %clear-state (state)
(loop for list in state
for package = (first list)
do (set-package-state package (list (string (gensym))
(list (string (gensym)))))))
(defun call-with-altered-state (state fn)
(let ((prior (state-of-the-world)))
(unwind-protect (progn
(%set-world-state state)
(funcall fn))
(%clear-state state)
(%set-world-state prior))))
(defun call-with-package-nicknames (names fn)
"names are a list of (list designator nickname)"
(let ((conflicts (list)))
(loop for list in names
for nick = (second list)
for existing = (find-package nick)
when existing
do (let* ((state (package-state existing))
(name (first state))
(nicks (second state))
(nick (string nick)))
(if (string= nick name)
;;change the name of the package
(push (list existing
(string (gensym name))
nicks)
conflicts)
;;change one of the package nicknames
(push (list existing
name
(cons (gensym nick)
(remove nick
nicks
:test 'string=)))
conflicts))))
(setq names (loop for (name nick) in names
for package = (find-package name)
collect
(cons package
(%augment-package-state
(package-state package)
nick))))
(call-with-altered-state (append conflicts names) fn)))