Coverage report: /home/ati/workspace/perec/query/query.lisp

Kind	Covered	All	%
expression	273	363	75.2
branch	29	40	72.5

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;; -*- mode: Lisp; Syntax: Common-Lisp; -*-

2

;;;

3

4

;;;

5

;;; See LICENCE for details.

6

7

(in-package :cl-perec)

8

9

;;(declaim-debug)

10

11

;;;

12

;;; Query

13

;;;

14

(defclass* query (copyable-mixin)

15

((lexical-variables

16

nil

17

:type (list lexical-variable))

18

(query-variables

19

nil

20

:type (list query-variable))

21

(body

22

nil

23

:type list)

24

(flatp

25

:writer (setf flatp)

26

:type boolean)

27

(uniquep

28

#f

29

:accessor uniquep

30

:type boolean)

31

(prefetchp

32

#t

33

:accessor prefetchp

34

:type boolean)

35

(result-type

36

'list

37

:type (member 'list 'scroll))))

38

39

(define-copy-method copy-inner-class progn ((self query) copy copy-htable)

40

(with-slot-copying (copy copy-htable self)

41

(copy-slots lexical-variables query-variables body flatp uniquep prefetchp result-type)))

42

43

(defmethod print-object ((query query) stream)

44

(print-unreadable-object (query stream :type t)

45

(prin1 (query-hash-key-for query) stream)))

46

47

(defun query-hash-key-for (query)

48

(list (mapcar 'name-of (lexical-variables-of query)) (select-form-of query)))

49

50

(defgeneric select-form-of (query)

51

(:method ((query query))

52

`(select ,(options-of query) ,(get-query-variable-names query)

53

,@(body-of query))))

54

55

(defgeneric options-of (query)

56

(:method ((query query))

57

(nconc

58

(when (slot-boundp query 'flatp)

59

(list :flatp (flatp query)))

60

(when (uniquep query)

61

(list :uniquep #t))

62

(when (not (prefetchp query))

63

(list :prefetchp #f))

64

(when (not (eq (result-type-of query) 'list))

65

(list :result-type (result-type-of query))))))

66

67

(defgeneric flatp (query)

68

(:method ((query query))

69

(and (slot-boundp query 'flatp)

70

(slot-value query 'flatp))))

71

72

(defmethod add-lexical-variable ((query query) variable-name)

73

(aprog1 (make-lexical-variable :name variable-name)

74

(push it (lexical-variables-of query))))

75

76

(defmethod add-query-variable ((query query) variable-name)

77

(aprog1 (make-query-variable :name variable-name)

78

(push it (query-variables-of query))))

79

80

(defun find-query-variable (query variable-name)

81

(find variable-name (query-variables-of query) :key 'name-of))

82

83

(defun find-lexical-variable (query variable-name)

84

(find variable-name (lexical-variables-of query) :key 'name-of))

85

86

(defun find-variable (query variable-name)

87

(or (find-query-variable query variable-name)

88

(find-lexical-variable query variable-name)))

89

90

(defun get-query-variable-names (query)

91

(mapcar 'name-of (query-variables-of query)))

92

93

(defun get-query-variable-types (query)

94

(mapcar 'xtype-of (query-variables-of query)))

95

96

(defun add-joined-variable (query variable)

97

(push variable (query-variables-of query)))

98

99

(defun get-variables (query)

100

(append (lexical-variables-of query) (query-variables-of query)))

101

102

;;;

103

;;; Simple query

104

;;;

105

(defclass* simple-query (query)

106

((asserts

107

nil

108

:type list

109

:documentation "List of conditions of assert forms.")

110

(action

111

:collect

112

:type (member :collect :purge))

113

(action-args

114

nil

115

:type list

116

:documentation "List of expressions of the action form.")

117

(order-by

118

nil

119

:type list

120

:documentation "Format: (:asc <expr1> :desc <expr2> ...)")

121

(where-clause

122

nil))

123

(:documentation "SIMPLE-QUERY only contains (assert ...) forms and one (collect ...) and

124

optionally an ORDER-BY clause form at top-level."))

125

126

(define-copy-method copy-inner-class progn ((self simple-query) copy copy-htable)

127

(with-slot-copying (copy copy-htable self)

128

(copy-slots asserts action action-args order-by where-clause)))

129

130

(defgeneric collects-of (query)

131

(:method ((query simple-query))

132

(debug-only (assert (eq (action-of query) :collect)))

133

(action-args-of query)))

134

135

(defgeneric (setf collects-of) (value query)

136

(:method (value (query simple-query))

137

(debug-only (assert (eq (action-of query) :collect)))

138

(setf (action-args-of query) value)))

139

140

(defmethod add-assert ((query simple-query) condition)

141

(appendf (asserts-of query) (list condition)))

142

143

(defmethod add-collect ((query simple-query) expression)

144

(appendf (collects-of query) (list expression)))

145

146

(defmethod add-order-by ((query simple-query) expression &optional (direction :asc))

147

(assert (member direction '(:asc :desc)))

148

(nconcf (order-by-of query) (list direction expression)))

149

150

(defmethod set-order-by ((query simple-query) expression &optional (direction :asc))

151

(assert (member direction '(:asc :desc)))

152

(setf (order-by-of query) (list direction expression)))

153

154

(defgeneric add-where-clause (query where-clause)

155

(:method ((query simple-query) where-clause)

156

(cond

157

((not (where-clause-of query))

158

(setf (where-clause-of query) where-clause))

159

((and (listp (where-clause-of query)) (eq (car (where-clause-of query)) 'sql-and))

160

(appendf (where-clause-of query) (list where-clause)))

161

(t

162

(setf (where-clause-of query)

163

`(sql-and ,(where-clause-of query) ,where-clause))))))

164

165

(defmethod body-of ((query simple-query))

166

`(,@(mapcar #L(`(assert ,!1)) (asserts-of query))

167

,(if (eq (action-of query) :collect)

168

`(collect ,@(collects-of query))

169

`(purge ,@(action-args-of query)))

170

,@(when (order-by-of query)

171

`(order-by ,@(order-by-of query)))))

172

173

(defmethod flatp ((query simple-query))

174

(if (slot-boundp query 'flatp)

175

(call-next-method)

176

(<= (length (collects-of query)) 1)))

177

178

;;;

179

;;; Query builder

180

;;;

181

(defclass* query-builder (copyable-mixin)

182

((current-query-variable nil)))

183

184

(define-copy-method copy-inner-class progn ((self query-builder) copy copy-htable)

185

(with-slot-copying (copy copy-htable self)

186

(copy-slots current-query-variable)))

187

188

(defclass* simple-query-builder (query-builder simple-query)

189

())

190

191

(defun preprocess-query-expression (query expression)

192

(setf expression (tree-substitute (name-of (current-query-variable-of query))

193

'*current-query-variable* expression))

194

expression)

195

196

(defmethod add-query-variable ((query query-builder) variable-name)

197

(setf (current-query-variable-of query) (call-next-method)))

198

199

(defmethod add-assert ((query simple-query-builder) condition)

200

(call-next-method query (preprocess-query-expression query condition)))

201

202

(defmethod add-collect ((query simple-query-builder) expression)

203

(call-next-method query (preprocess-query-expression query expression)))

204

205

(defmethod add-order-by ((query simple-query-builder) expression &optional (direction :asc))

206

(call-next-method query (preprocess-query-expression query expression) direction))

207

208

;;;

209

;;; Parse select forms

210

;;;

211

(defmethod make-query ((select-form null) &optional lexical-variables)

212

(let ((query (make-instance 'simple-query-builder)))

213

(iter (for variable in lexical-variables)

214

(add-lexical-variable query variable))

215

query))

216

217

(defmethod make-query ((select-form cons) &optional lexical-variables)

218

219

(labels ((select-macro-expand (select-form)

220

(if (eq (first select-form) 'select)

221

select-form

222

(bind (((values select-form expanded-p) (macroexpand-1 select-form)))

223

(if expanded-p

224

(select-macro-expand select-form)

225

select-form))))

226

(make-lexical-variables (variable-names)

227

(iter (for variable-name in variable-names)

228

(collect (make-lexical-variable :name variable-name))))

229

(make-query-variables (variable-specs)

230

(iter (for variable-spec in variable-specs)

231

(typecase variable-spec

232

(symbol (collect (make-query-variable :name variable-spec)))

233

(cons (collect (make-query-variable :name (car variable-spec))))

234

                      (otherwise (error "Symbol or symbol/type pair expected, found ~S in select: ~:W"

235

variable-spec select-form)))))

236

(add-variable-type-asserts (variable-specs body)

237

(dolist (variable-spec variable-specs body)

238

(when (and (listp variable-spec) (>= (length variable-spec) 2))

239

                  (push `(assert (typep ,(first variable-spec) ',(second variable-spec))) body))))

240

(make-query (options vars body)

241

(bind ((lexical-variables (make-lexical-variables lexical-variables))

242

(query-variables (make-query-variables vars))

243

(body (add-variable-type-asserts vars body))

244

(collect-form (find 'collect body :key 'first :test 'eq))

245

(purge-form (find 'purge body :key 'first :test 'eq))

246

(order-by-form (find 'order-by body :key 'first :test 'eq))

247

                     (other-forms (remove order-by-form (remove purge-form (remove collect-form body))))

248

(simple-query-p (and (or collect-form purge-form)

249

                                          (every #L(eql (car !1) 'assert) other-forms))))

250

251

(if simple-query-p

252

(apply 'make-instance 'simple-query

253

:lexical-variables lexical-variables

254

:query-variables query-variables

255

:body body

256

:asserts (mapcar 'second other-forms)

257

:action (if collect-form :collect :purge)

258

                           :action-args (if collect-form (cdr collect-form) (cdr purge-form))

259

:order-by (cdr order-by-form)

260

options)

261

(apply 'make-instance 'query

262

:lexical-variables lexical-variables

263

:query-variables query-variables

264

:body body

265

options)))))

266

267

(pattern-case (select-macro-expand select-form)

268

((select (?and ((?is ?k keywordp) . ?rest) ?options) (?is ?variable-specs listp) . ?body)

269

(make-query ?options ?variable-specs ?body))

270

((select (?is ?variable-specs listp) . ?body)

271

(make-query nil ?variable-specs ?body))

272

(?otherwise

273

(error "Malformed select statement: ~:W" select-form)))))