Coverage report: /home/ellis/comp/core/lib/organ/graph.lisp

Kind	Covered	All	%
expression	0	364	0.0
branch	0	12	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; graph.lisp --- Org Graph Lisp API

2

3

;;

4

5

;;; Code:

6

(in-package :organ/graph)

7

8

(load-database-backend :rdb)

9

(blake3:load-blake3)

10

11

(deftype org-id () `(octet-vector 16))

12

13

;;; Schema

14

(defclass org-graph-schema (rdb-schema) ()

15

(:default-initargs

16

:fields (make-fields :file '(pathname . octet-vector)

17

:title '(org-id . string)

18

:hash '(org-id . string)

19

:atime '(org-id . octet-vector)

20

:mtime '(org-id . octet-vector)

21

:node '(org-id . octet-vector)

22

:edge '(org-id . octet-vector)

23

:node-tags '(org-id . string)

24

:node-links '(org-id . string)

25

:node-properties '(org-id . string)

26

:node-priority '(org-id . string)

27

:node-schedule '(org-id . string)

28

:node-file '(org-id . string)

29

:node-pos '(org-id . octet-vector)

30

:node-state '(org-id . string))))

31

32

(defparameter *org-graph-schema* (make-instance 'org-graph-schema))

33

34

(define-condition org-id-locations-out-of-sync (simple-error) ())

35

36

(defvar *org-graph-file* (merge-pathnames ".emacs.d/graph.sxp" (user-homedir-pathname)))

37

(defvar *org-id-locations-file* (merge-pathnames ".emacs.d/.org-id-locations" (user-homedir-pathname)))

38

39

;;; Org IDs

40

(defun make-org-id-locations (&optional (file *org-id-locations-file*))

41

(let ((tbl (make-hash-table :test 'equal)))

42

(with-open-file (file file)

43

(dolist (entry (read file))

44

(if-let ((file (probe-file (car entry))))

45

(setf (gethash (namestring file) tbl) (cdr entry))

46

           (signal 'org-id-locations-out-of-sync :format-control "~A" :format-arguments (list entry)))))

47

tbl))

48

49

(defun uuid-octets* (id)

50

(handler-case (uuid-to-octet-vector id)

51

(simple-error () id)

52

(sb-pcl::missing-slot () id)))

53

54

;;; Org Graph

55

(defvar *org-graph* nil)

56

57

(defstruct org-graph nodes edges)

58

59

(defmethod read-ast ((fmt (eql :org-graph)) stream &key)

60

(let ((graph (apply 'make-org-graph (read stream))))

61

(setf #1=(org-graph-nodes graph)

62

(mapcar (lambda (x) (wrap (make-instance 'org-graph-node) x)) #1#)

63

#2=(org-graph-edges graph)

64

(mapcar (lambda (x) (wrap (make-instance 'org-graph-edge) x)) #2#))

65

graph))

66

67

(defmethod build-ast ((self org-graph) &key)

68

`(:nodes ,(mapcar 'build-ast (org-graph-nodes self))

69

:edges ,(mapcar 'build-ast (org-graph-edges self))))

70

71

(defun read-org-graph-file (&optional (file *org-graph-file*))

72

(with-open-file (f file) (read-ast :org-graph f)))

73

74

(defun init-org-graph ()

75

(setf *org-graph* (read-org-graph-file)))

76

77

(defclass org-graph-node (vertex)

78

((name :initarg :name :accessor name)

79

(path :initarg :path :accessor path)

80

(point :initarg :point :accessor idx)))

81

82

(defmethod wrap ((self org-graph-node) form)

83

(make-instance 'org-graph-node

84

:id (make-uuid-from-string (pop form)) :name (pop form) :path (pop form) :point (pop form)))

85

86

(defmethod build-ast ((self org-graph-node) &key)

87

`(,(uuid-to-string (id self)) ,(name self) ,(path self) ,(idx self)))

88

89

(defclass org-graph-edge (edge)

90

((type :initarg :type :accessor edge-type)

91

(properties :initarg :properties :accessor edge-properties)

92

(timestamp :initarg :timestamp :accessor timestamp)

93

(point :initarg :point :accessor idx)))

94

95

(defmethod wrap ((self org-graph-edge) form)

96

(make-instance 'org-graph-edge

97

:type (pop form)

98

:in (make-uuid-from-string (pop form))

99

:properties (pop form)

100

:timestamp

101

(destructuring-bind (sec minute hour day month year timezone a1 a2) (pop form)

102

(declare (ignore a1 a2))

103

(encode-timestamp 0 sec minute hour day month year :timezone (or timezone *default-timezone*)))

104

:point (pop form)

105

:out (pop form)))

106

107

(defmethod build-ast ((self org-graph-edge) &key)

108

`(,(keywordicate (edge-type self)) ,(uuid-to-string (edge-in self)) ,(edge-properties self)

109

,(timestamp-to-universal (timestamp self)) ,(idx self) ,(format nil "~A" (edge-out self))))

110

111

(defstruct org-graph-file

112

"Internal helper struct used while processing files in the *ORG-GRAPH*."

113

path document timestamp hash)

114

115

(defun org-graph-extract-files (&optional (graph *org-graph*))

116

(let ((ret))

117

(dolist (n (remove-duplicates (org-graph-nodes graph) :test 'string= :key 'path) ret)

118

(push (wrap (make-org-graph-file) (probe-file (path n))) ret))))

119

120

(defmethod id ((self org-graph-file))

121

(org-graph-file-hash self))

122

123

(defmethod wrap ((self org-graph-file) (file pathname))

124

(setf (org-graph-file-hash self) (b3sum file)

125

(org-graph-file-path self) file

126

(org-graph-file-timestamp self) (universal-to-timestamp (file-write-date file))

127

(org-graph-file-document self) (organ:org-parse :document file))

128

self)

129

130

(defmethod wrap ((self org-graph-file) (node org-graph-node))

131

(let ((file (path node)))

132

(setf (org-graph-file-hash self) (b3sum file)

133

(org-graph-file-path self) file

134

(org-graph-file-document self) (organ:org-parse :document file))

135

self))

136

137

(defun insert-org-files ()

138

(log:info! "inserting org files")

139

(mapcar

140

(lambda (n) (insert-key *org-graph-db* (uuid-octets* (id n)) (path n) :column "file"))

141

(org-graph-nodes *org-graph*)))

142

143

(defun insert-org-nodes ()

144

(log:info! "inserting org nodes")

145

(dolist (id (mapcar 'id (org-graph-nodes *org-graph*)))

146

(insert-key *org-graph-db*

147

(uuid-octets* id)

148

;; TODO 2024-12-30:

149

#(1)

150

:column "node")))

151

152

(defun insert-org-edges ()

153

(log:info! "inserting org edges")

154

(dolist (e (org-graph-edges *org-graph*))

155

(insert-key *org-graph-db*

156

(uuid-octets* (edge-in e))

157

(uuid-octets* (edge-out e))

158

:column "edge")))

159

160

;; (loop with i = 0

161

;; while (iter-valid-p it)

162

;; do (log:info! (iter-key it) (iter-val it))

163

;; do (iter-next it)

164

;; do (print (incf i))))

165

166

;;; Org Graph DB

167

(defvar *org-graph-db-directory* (merge-pathnames ".store/db/graph/" (user-homedir-pathname)))

168

169

(defun make-org-graph-db ()

170

(load-schema

171

(make-db :rdb :name (namestring *org-graph-db-directory*)

172

:opts (default-rdb-opts))

173

*org-graph-schema*))

174

175

(defvar *org-graph-db* nil)

176

177

(defun close-org-graph-db ()

178

(when (db-open-p *org-graph-db*)

179

(shutdown-db *org-graph-db*)))

180

181

(defun init-org-graph-db ()

182

(ensure-directories-exist

183

(make-pathname :directory (butlast (pathname-directory *org-graph-db-directory*)))

184

:verbose t)

185

(with-db (db :open (not (db-open-p *org-graph-db*)) :close nil :db *org-graph-db*)

186

(create-columns db)

187

(insert-org-files)

188

(insert-org-nodes)

189

(insert-org-edges)

190

(log:info! "created org-graph-db" *org-graph-db* *org-graph-db-directory* *org-graph-schema*)))

191

192

(defun open-org-graph-db ()

193

(unless *org-graph* (init-org-graph))

194

(unless (probe-file *org-graph-db-directory*)

195

(init-org-graph-db))

196

(if (and *org-graph-db* (db-open-p *org-graph-db*))

197

*org-graph-db*

198

(progn

199

(load-opts *org-graph-db*)

200

(open-columns* *org-graph-db*))))

201

202

(defun destroy-org-graph-db ()

203

(unless (db-closed-p *org-graph-db*)

204

(close-db *org-graph-db*)

205

(log:info! "destroyed org-graph-db at ~A" *org-graph-db-directory*)))

206

207

(defun og-get (key &optional (from "node"))

208

(get-val *org-graph-db* key :data-type 'string :column from))

209

210

(defun og-values (column)

211

(with-iter (it (iter *org-graph-db* :column (find-column column *org-graph-db*)))

212

(seek-to-first)

213

(loop while (iter-valid-p)

214

collect (cons (handler-case (octet-vector-to-uuid (key))

215

(simple-type-error () (sb-ext:octets-to-string (key))))

216

(sb-ext:octets-to-string (val)))

217

do (next))))

218

219

;;; Files

220

(defun org-graph-file-search (path &rest ids)

221

"Return a list of org headings corresponding to IDS in PATH."

222

;; first get an org-document and list of headings

223

(let* ((doc (organ:org-parse :document path))

224

(headings (organ:doc-tree doc))

225

(ret))

226

;; map over IDs, searching for matches

227

(loop for h across headings

228

if (typep h 'organ:org-heading)

229

do

230

(push

231

(when-let* ((prop (organ::org-properties h))

232

                           (id (find (print (value (find "ID" (print (organ:org-contents prop))

233

                                                         :key (lambda (x) (string-upcase (name x))))))

234

ids

235

:test 'equal)))

236

(removef ids id :test 'equal)

237

h)

238

ret)

239

finally (return ret))))

240

241

;;; Serde

242

(defmethod serialize ((self org-graph) format &key stream)

243

(serialize (build-ast self) format :stream stream))