Coverage report: /home/ellis/comp/core/app/skel/core/util.lisp

Kind	Covered	All	%
expression	5	280	1.8
branch	0	24	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; Utils

2

(in-package :skel/core/util)

3

;;; Configs

4

5

;; init-*,load-*

6

(defun load-skelrc (&optional (usr-path user-skelrc) (sys-path system-skelrc))

7

(values

8

(load-system-skelrc sys-path)

9

(load-user-skelrc usr-path)))

10

11

(defun init-user-skelrc (&optional (file user-skelrc))

12

"Initialize a skelrc configuration based on the currently active

13

*SKEL-USER-CONFIG*. Defaults to ~/.skelrc."

14

(sk-write-file (make-instance 'sk-user-config)

15

:path file

16

:pretty t))

17

18

(defun init-system-skelrc (&optional (file system-skelrc))

19

"Initialize a system skelrc configuration based on the currently active

20

*SKEL-SYSTEM-CONFIG*."

21

(sk-write-file (make-instance 'sk-system-config)

22

:path file

23

:pretty t))

24

25

(defun load-user-skelrc (&optional (file user-skelrc) (init t))

26

"Load a user-skelrc configuration from FILE. Defaults to USER-SKELR*.

27

28

If FILE does not exists, it is created with a default configuration."

29

(flet ((%load ()

30

(setq *skel-user-config*

31

(load-ast

32

(make-instance 'sk-user-config

33

:ast #1=(file-read-forms file)

34

:id (sxhash #1#)

35

:path file)))))

36

(if (not init)

37

(progn

38

(assert (probe-file file))

39

(%load))

40

(if (probe-file file)

41

(%load)

42

(init-user-skelrc file)))))

43

44

(defun load-system-skelrc (&optional (file system-skelrc) auto)

45

"Load a skelrc configuration from FILE. Defaults to /etc/skel/skelrc.

46

47

Unlike LOAD-USER-SKELRC we don't generate a default file if one

48

doesn't exist, since it is assumed to be write-protected. This can be

49

overwritten with the AUTO flag."

50

(if-let ((f (probe-file file)))

51

(setq *skel-system-config*

52

           (load-ast (make-instance 'sk-system-config :ast #1=(file-read-forms f) :id (sxhash #1#) :path f)))

53

(if auto

54

(init-system-skelrc)

55

*skel-system-config*)))

56

57

(eval-always

58

(defun load-skelfile (file)

59

"Load the 'skelfile' FILE."

60

(load-ast (sk-read-file (make-instance 'sk-project) file)))

61

62

(defun find-sk-project-root (path &optional (name *default-skelfile*))

63

"Return the root location of a `skel-project' by checking for

64

NAME."

65

(if (probe-merge-file path name)

66

path

67

(let ((next (pathname-parent-directory-pathname path)))

68

(unless (uiop:pathname-equal next path)

69

(find-sk-project-root next name)))))

70

71

(defun find-sk-file (path ext)

72

"Return the next SK-FILE at PATH matching the extension EXT."

73

(if-let ((match (directory (merge-pathnames (format nil "*.~a" ext) path))))

74

match

75

(if-let ((match-root (directory (merge-pathnames *default-skelfile* path))))

76

match-root

77

(let ((next (pathname-parent-directory-pathname path)))

78

(find-sk-file next ext)))))

79

80

(defun init-skelfile (&optional file name config)

81

"Initialize a skelfile."

82

(let ((sk (make-instance 'sk-project

83

:name (or name (pathname-name (sb-posix:getcwd)))))

84

(path (or file *default-skelfile*))

85

(fmt :pretty))

86

(when config (setf sk (sk-install-user-config sk config)))

87

(sk-write-file sk :path path :fmt fmt))))

88

89

(defun find-skelfile (start &key (load nil) (name *default-skelfile*) (ext "sk") (walk t) error)

90

"Walk up the current directory returning the path to a 'skelfile' by NAME or a

91

filename with extension EXT, else return nil. When LOAD is non-nil, load the

92

skelfile if found."

93

;; Check the current path, if no skelfile found, walk up a level and

94

;; continue until the `*skelfile-boundary*' is triggered.

95

(labels ((%check (dir)

96

(or (probe-merge-file name dir)

97

                  (when-let ((match (directory (merge-pathnames dir (format nil "*.~a" ext)))))

98

(probe-file (car match)))

99

(probe-merge-file (make-pathname :name name :type ext) dir)))

100

(%walk (dir)

101

(or (%check dir)

102

(let ((next (pathname-parent-directory-pathname dir)))

103

(if (uiop:pathname-equal next dir)

104

(when error (skel-simple-error "failed to find root skelfile"))

105

(%walk next)))))

106

(%load? (file) (if load (load-skelfile file) file)))

107

(setf start (car (directory start)))

108

(if-let ((match (%check start)))

109

(%load? match)

110

(if walk

111

(when-let ((match (%walk start)))

112

(%load? match))

113

(when error (skel-simple-error "failed to find root skelfile"))))))

114

115

(defun edit-skelrc ()

116

"Open the current user configuration using ED."

117

(ed user-skelrc))

118

119

(defun edit-system-skelrc ()

120

"Open the current system configuration using ED."

121

(ed system-skelrc))

122

123

(defun sk-config-slot (slot &optional (default :error))

124

"First check *SKEL-USER-CONFIG* for a slot value, and if a valid value

125

isn't found check *SKEL-SYSTEM-CONFIG*."

126

(let ((slot (find-symbol (string-upcase (string slot)) :skel/core/obj)))

127

(if (or (null *skel-user-config*) (not (slot-boundp* *skel-user-config* slot)))

128

(if (or (null *skel-system-config*) (not (slot-boundp* *skel-system-config* slot)))

129

(if (eql default :error)

130

(skel-simple-error "slot is unbound in skelrc")

131

default)

132

(slot-value *skel-system-config* slot))

133

(slot-value *skel-user-config* slot))))

134

135

(defun sk-project-slot (slot &optional (default :error))

136

(let ((slot (find-symbol (string-upcase (string slot)) :skel/core/obj)))

137

(if (or (null *skel-project*) (not (slot-boundp* *skel-project* slot)))

138

;; Not found in project, search config files instead

139

(sk-config-slot slot default)

140

(slot-value *skel-project* slot))))

141

142

(defun sk-search-project (query &optional (project *skel-project*)

143

(user-config *skel-user-config*)

144

                                           (system-config *skel-system-config*))

145

"Search the current project for elements matching QUERY."

146

(etypecase query

147

(string (or (sk-find query project)

148

(sk-find query user-config)

149

(when system-config

150

(sk-find query system-config))))

151

(integer (or (sk-find query project :slot :id)

152

(sk-find query user-config :slot :id)

153

(when system-config

154

(sk-find query system-config :slot :id))))

155

(keyword (sk-project-slot query))))

156

157

(macrolet

158

((%init (set)

159

`(with-readtable :shell

160

(load-skelrc)

161

(when-let ((cache (sk-config-slot :cache nil)))

162

(,set skel-cache (ensure-directory-truename cache)))

163

(when-let ((store (sk-config-slot :store nil)))

164

(,set skel-store (ensure-directory-truename store)))

165

(when-let ((stash (sk-config-slot :stash nil)))

166

(,set skel-stash (ensure-directory-truename stash)))

167

(when-let ((registry (sk-config-slot :registry nil)))

168

(,set skel-registry (ensure-directory-truename registry)))

169

(when-let ((project (find-skelfile *default-pathname-defaults*)))

170

(,set *skel-project* (load-skelfile project)

171

skel-path (sk-src *skel-project*)))

172

(when-let ((hooks *skel-init-hook*))

173

(mapc 'funcall hooks))

174

(values))))

175

176

(defun init-skel ()

177

"Initialize the global SKEL environment:

178

179

*SKEL-SYSTEM-CONFIG*

180

*SKEL-USER-CONFIG*

181

*SKEL-PROJECT*

182

SKEL-CACHE

183

SKEL-STORE

184

SKEL-STASH

185

SKEL-REGISTRY

186

:IF-FEATURE :DB

187

*SKEL-LOGGER*"

188

(%init setq))

189

(defun setf-skel-vars () (%init setf)))

190

191

;; (defmacro sk-apply-path-relevancy (path &optional (context *default-pathname-defaults*)))

192

193

(defun list-all-projects ())

194

195

(defun project-root (&optional (project *skel-project*))

196

(or (when project (sk-src project)) *default-pathname-defaults*))