Coverage report: /home/ellis/comp/core/ffi/tree-sitter/api.lisp

Kind	Covered	All	%
expression	130	238	54.6
branch	12	24	50.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; ffi/tree-sitter/api.lisp --- High-level API for Tree-sitter library

2

3

;; High-level Tree-sitter API

4

5

;;; Code:

6

(in-package :tree-sitter)

7

8

(defstruct (node (:type list))

9

type range children)

10

11

(defun make-lisp-name (string)

12

(intern (string-upcase (substitute #\- #\_ string))

13

(load-time-value (find-package "KEYWORD"))))

14

15

(define-condition tree-sitter-error (error)

16

())

17

18

(define-condition create-parser-error (tree-sitter-error)

19

())

20

21

(define-condition set-language-error (tree-sitter-error)

22

((language :initarg :language :reader tree-sitter-error-language)))

23

24

(define-condition parse-string-error (tree-sitter-error)

25

((string :initarg :string :reader tree-sitter-error-string)

26

(string-start :initarg :string-start :reader tree-sitter-error-string-start)

27

(string-end :initarg :string-end :reader tree-sitter-error-string-end)

28

(language :initarg :language :reader tree-sitter-error-language)))

29

30

(define-condition null-node-pointer (tree-sitter-error)

31

())

32

33

(define-condition null-tree-cursor-pointer (tree-sitter-error)

34

())

35

36

(define-condition tree-sitter-query-error (tree-sitter-error)

37

((offset :initarg :offset :reader tree-sitter-error-offset)

38

(type :initarg :type :reader tree-sitter-error-type))

39

(:report (lambda (c s)

40

(format s "~A of type ~A occurred at offset ~A."

41

(class-name (class-of c))

42

(tree-sitter-error-type c)

43

(tree-sitter-error-offset c)))))

44

45

(defun check-ts-query-error (type &optional (offset 0))

46

(unless (zerop type) ;; pass

47

(error 'tree-sitter-query-error :type (ts-query-error* type) :offset offset)))

48

49

;; util

50

(defmacro with-ts-parser ((sym &key lang) &body body)

51

(let ((%lang (when lang (language-module lang))))

52

`(let ((,sym (ts-parser-new))

53

,@(if (atom lang) nil `(,(pop lang) ,%lang)))

54

,@(when lang `(ts-parser-set-language ,%lang))

55

(unwind-protect (progn ,@body)

56

(ts-parser-delete ,sym)))))

57

58

(defmacro with-ts-lang (lang sym &body body)

59

`(let ((,sym (language-module ,lang)))

60

,@body))

61

62

(defmacro with-ts-node ((var node) &body forms)

63

`(let ((,var ,node))

64

(when (sb-alien:null-alien ,var)

65

(error 'null-node-pointer))

66

(unwind-protect

67

(progn ,@forms)

68

(sb-alien:free-alien ,var))))

69

70

(defmacro with-ts-cursor ((var tree) &body forms &aux (node (gensym)))

71

`(with-ts-node (,node (ts-tree-root-node-pointer ,tree))

72

(let ((,var (ts-tree-cursor-new-pointer ,node)))

73

(when (sb-alien:null-alien ,var)

74

(error 'null-tree-cursor-pointer))

75

(unwind-protect

76

(progn ,@forms)

77

(ts-tree-cursor-delete ,var)))))

78

79

(defmacro with-ts-query ((var lang string &optional (length '(length string))) &body body)

80

(with-gensyms (eoff etype)

81

`(with-alien ((,eoff unsigned-int)

82

(,etype ts-query-error))

83

(let ((,var (ts-query-new (language-module ,lang) (make-alien-string ,string) ,length

84

(addr ,eoff) (addr ,etype))))

85

(check-ts-query-error ,etype ,eoff)

86

,@body))))

87

88

(defmacro with-ts-query-cursor (var &body body)

89

`(let ((,var (ts-query-cursor-new)))

90

,@body))

91

92

 (defun parse-string (language string &key (start 0) end consume produce-cst (name-generator #'make-lisp-name))

93

"Parse a STRING that represents LANGUAGE code using tree-sitter. START is

94

where to start parsing STRING. END is where to stop parsing STRING.

95

When PRODUCE-CST is set, the full concrete syntax tree will be produced as

96

opposed to the abstract syntax tree. See 'Named vs Anonymous Nodes':

97

http://tree-sitter.github.io/tree-sitter/using-parsers#named-vs-anonymous-nodes

98

NAME-GENERATOR is a function which converts a string from tree-sitter into a

99

desired name for use in lisp."

100

(let ((parser (ts-parser-new)))

101

(when (sb-alien:null-alien parser)

102

(error 'cant-create-parser))

103

(unwind-protect (parse-string-with-language language string parser

104

:start start

105

:end end

106

:consume consume

107

                                                 :produce-cst produce-cst

108

                                                 :name-generator name-generator)

109

(ts-parser-delete parser))))

110

111

112

(defun parse-string-with-language (language string parser

113

&key (start 0) end produce-cst

114

(consume t)

115

(name-generator #'make-lisp-name))

116

(unless (ts-parser-set-language parser (language-module language))

117

(error 'cant-set-language :language language))

118

(let* ((string-start start)

119

(string-end (or end (length string)))

120

;; TODO: this might need to be +1 if it's actually a c-string for null

121

(string-length (- string-end string-start))

122

(string-to-pass (if (plusp string-start)

123

(subseq string string-start string-end)

124

string))

125

(tree (ts-parser-parse-string parser nil string-to-pass string-length)))

126

(when (sb-alien:null-alien tree)

127

(error 'cant-parse-string

128

:string string

129

:string-start start

130

:string-end end

131

:language language))

132

(if consume

133

(unwind-protect (convert-foreign-tree-to-list tree :produce-cst produce-cst

134

                                                            :name-generator name-generator)

135

(ts-tree-delete tree))

136

tree)))

137

138

(defun ts-point-cons (p)

139

(unless (sb-alien:null-alien p)

140

(with-alien-slots (tree-sitter::row tree-sitter::column) p

141

(cons tree-sitter::row tree-sitter::column))))

142

143

(defun ts-node-start (node)

144

"Return a cons (ROW . COL) indicating the file-position of the start of NODE."

145

(sb-alien:with-alien ((p (* ts-point) (ts-node-start-point-pointer node)))

146

(ts-point-cons p)))

147

148

(defun ts-node-end (node)

149

"Return a cons (ROW . COL) indicating the file-position of the end of NODE."

150

(sb-alien:with-alien ((p (* ts-point) (ts-node-end-point-pointer node)))

151

(unless (sb-alien:null-alien p)

152

(with-alien-slots (tree-sitter::row tree-sitter::column) (sb-alien:deref p)

153

(cons tree-sitter::row tree-sitter::column)))))

154

155

(definline ts-node-start-byte (node)

156

(tree-sitter::ts-node-start-byte-pointer node))

157

(definline ts-node-end-byte (node)

158

(tree-sitter::ts-node-end-byte-pointer node))

159

160

(defun convert-foreign-tree-to-list (tree &key produce-cst name-generator

161

&aux did-visit-children parse-stack)

162

(with-ts-cursor (cursor tree)

163

;; Closely follows tree-sitter-cli parse

164

;; implementation with a modification to

165

;; allow for production of the full CST.

166

(loop

167

(with-ts-node (node (ts-tree-cursor-current-node-pointer cursor))

168

(let ((is-named (or produce-cst (ts-node-is-named-pointer node))))

169

(cond (did-visit-children

170

(when (and is-named (second parse-stack))

171

(let ((item (pop parse-stack)))

172

(setf (node-children item)

173

(nreverse (node-children item)))

174

(push item (node-children (first parse-stack)))))

175

(cond ((ts-tree-cursor-goto-next-sibling cursor)

176

(setf did-visit-children nil))

177

((ts-tree-cursor-goto-parent cursor)

178

(setf did-visit-children t))

179

(t

180

(let ((root (first parse-stack)))

181

(setf (node-children root)

182

(nreverse (node-children root)))

183

(return root)))))

184

(t

185

(when is-named

186

(let ((start-point (ts-node-start-byte node))

187

(end-point (ts-node-end-byte node))

188

(type (funcall name-generator (ts-node-type-pointer node)))

189

(field-name (ts-tree-cursor-current-field-name cursor)))

190

                      (when field-name (setf type (list (funcall name-generator field-name) type)))

191

(push (make-node :type type :range (list start-point end-point))

192

parse-stack)))

193

(setf did-visit-children

194

(not (ts-tree-cursor-goto-first-child cursor))))))))))