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

Kind	Covered	All	%
expression	1073	1301	82.5
branch	70	100	70.0

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

(enable-pattern-reader #\M)

12

13

;;;; TODO: sorting and grouping

14

;;;; TODO: embedded SQL in queries

15

;;;; TODO: return nil if there is contradiction between asserts

16

;;;; TODO: eliminate tautologies from asserts

17

;;;; TODO: n-m associations

18

;;;; TODO: delete and update operations

19

;;;; TODO: recursive selects

20

21

;;;

22

;;; Compile queries

23

;;;

24

(defvar *compile-query-counter* 0

25

"Number of calls to COMPILE-QUERY. (FOR TESTING)")

26

27

(defvar *test-query-compiler* nil

28

"When true, the compiled form performs a runtime check by comparing the result of the query

29

with the result of the naively compiled query.")

30

31

(defun reset-compile-query-counter ()

32

(setf *compile-query-counter* 0))

33

34

(defmethod compile-query :before (query)

35

(incf *compile-query-counter*))

36

37

(defmethod compile-query ((query query))

38

(%compile-query (make-instance 'trivial-query-compiler) query))

39

40

(defmethod compile-query ((query simple-query))

41

(if *test-query-compiler*

42

(%compile-query (make-instance 'debug-query-compiler) query)

43

(%compile-query (make-instance 'simple-query-compiler) query)))

44

45

(defclass* query-compiler ()

46

()

47

(:documentation "Generic query compiler, which can transform to sql to any select form."))

48

49

(defgeneric %compile-query (compiler query)

50

(:documentation "Compiles the query with the specified compiler."))

51

52

(defmethod %compile-query ((compiler query-compiler) (query query))

53

(unparse-query-syntax

54

(optimize-query

55

compiler

56

(emit-query

57

compiler

58

(transform-query

59

compiler

60

query)))))

61

62

(defgeneric transform-query (compiler query)

63

(:documentation "TODO")

64

65

(:method (compiler query)

66

query))

67

68

(defgeneric emit-query (compiler query)

69

(:documentation "TODO"))

70

71

(defgeneric optimize-query (compiler syntax)

72

(:documentation "TODO")

73

74

(:method (compiler syntax)

75

syntax))

76

77

;;;;

78

;;;; Trivial query compiler

79

;;;;

80

(defclass* trivial-query-compiler (query-compiler)

81

()

82

   (:documentation "Query compiler that can compile any select form, but does not optimize sql queries."))

83

84

(defmethod emit-query ((compiler trivial-query-compiler) query)

85

(bind ((lexical-variables (lexical-variables-of query))

86

(variables (get-query-variable-names query))

87

(body (body-of query))

88

(body (mapcar 'query-macroexpand body))

89

(persistent-object-literals (collect-persistent-object-literals body))

90

(persistent-object-variables (mapcar #L(gensym (symbol-name (class-name (class-of !1))))

91

                                               persistent-object-literals)))

92

(with-unique-names (objects result-list)

93

`(lambda ,lexical-variables

94

(declare (ignorable ,@lexical-variables))

95

,@(mapcar #L(`(load-instance ,!1)) persistent-object-literals)

96

         (let (,@(mapcar #L(`(,!1 (load-instance ,!2))) persistent-object-variables persistent-object-literals)

97

(,objects (mapcar 'cache-object

98

                                 (execute ,(sql-select-oids-for-class 'persistent-object))))

99

(,result-list nil))

100

(flet ((assert! (cond) (when (not cond) (throw 'fail nil)))

101

(collect (&rest exprs) (push exprs ,result-list))

102

(purge (&rest objects) (mapc 'make-transient objects))

103

(order-by (&rest order-spec) nil)) ; TODO

104

             (declare (ignorable (function assert!) (function collect) (function purge) (function order-by)))

105

(bind-cartesian-product ((,@variables) ,objects)

106

(catch 'fail

107

(progn

108

,@(sublis

109

(cons '(assert . assert!)

110

                            (mapcar 'cons persistent-object-literals persistent-object-variables))

111

body)))))

112

,(add-conversion-to-result-type

113

query

114

(add-unique-filter

115

query

116

`(make-list-result-set (nreverse ,result-list)))))))))

117

118

;;;;

119

;;;; Debug query compiler

120

;;;;

121

(defclass* debug-query-compiler (query-compiler)

122

()

123

(:documentation "Generic query compiler, which can transform to sql to any select form and

124

wraps the compiled code with a runtime check of the result."))

125

126

(defmethod %compile-query ((compiler debug-query-compiler) (query query))

127

"Emits code that checks that the result of COMPILED-FORM equals

128

to the result of the PREDICATE-FORM."

129

(let* ((predicate-form (%compile-query (make-instance 'trivial-query-compiler) query))

130

(compiled-form (%compile-query (make-instance 'simple-query-compiler) query))

131

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

132

(with-unique-names (result expected result-list expected-list)

133

(unparse-query-syntax

134

`(lambda ,lexical-variables

135

(declare (ignorable ,@lexical-variables))

136

(bind ((,result (funcall ,compiled-form ,@lexical-variables))

137

(,expected (funcall ,predicate-form ,@lexical-variables))

138

(,result-list (to-list ,result))

139

(,expected-list (to-list ,expected)))

140

;; TODO: set-exclusive-or is not ok for comparing the results, because

141

;; the result is not a set and (set-exclusive-or '(a b b) '(a a b))

142

;; returns NIL.

143

(when (set-exclusive-or ,result-list ,expected-list :test 'equal)

144

(cerror "Return the expected result." 'query-error

145

:query ,query :result ,result-list :expected ,expected-list))

146

,expected))))))

147

148

(define-condition query-error ()

149

((query :initarg :query)

150

(result :initarg :result)

151

(expected :initarg :expected))

152

153

(:report (lambda (condition stream)

154

(format stream "Query ~S failed. Result is ~:W, but expected ~:W."

155

(slot-value condition 'query)

156

(slot-value condition 'result)

157

(slot-value condition 'expected))))

158

159

(:documentation "Condition signalling that the runtime check of the query failed."))

160

161

;;;;---------------------------------------------------------------------------

162

;;;; Simple query compiler

163

;;;;

164

(defclass* simple-query-compiler (query-compiler)

165

()

166

(:documentation "Query compiler that can transform to sql to simple select forms."))

167

168

(defmethod emit-query ((compiler simple-query-compiler) (query simple-query))

169

(ecase (action-of query)

170

(:collect (emit-select query))

171

(:purge (emit-purge query))))

172

173

(defun emit-purge (query)

174

(bind ((lexical-variables (lexical-variables-of query))

175

(asserts (asserts-of query))

176

(variables (query-variables-of query))

177

(purge-var (first (action-args-of query)))

178

(type (xtype-of purge-var))

179

(substitutions (generate-persistent-object-substitutions query)))

180

(if asserts

181

;; execute deletes from lisp filter

182

(with-unique-names (row)

183

`(lambda ,lexical-variables

184

(declare (ignorable ,@lexical-variables))

185

(let (,@(emit-persistent-object-bindings substitutions))

186

,(substitute-syntax

187

`(execute ,(sql-select-for-query query)

188

:visitor

189

(lambda (,row)

190

(let ,(emit-query-variable-bindings variables row #f)

191

,(emit-ignorable-variables-declaration variables)

192

(when (and ,@asserts)

193

(make-transient ,(first (action-args-of query)))))))

194

substitutions))))

195

;; execute deletes from sql

196

(bind (((values deletes cleanup) (sql-deletes-for-query query)))

197

`(lambda ,lexical-variables

198

(declare (ignorable ,@lexical-variables))

199

(let (,@(emit-persistent-object-bindings substitutions))

200

(invalidate-persistent-flag-of-cached-objects (find-persistent-class* ,type))

201

,(substitute-syntax

202

(if cleanup

203

`(unwind-protect (mapc 'execute ,deletes) (execute ,cleanup))

204

`(mapc 'execute ,deletes))

205

substitutions)))))))

206

207

(defun emit-select (query)

208

"Emits code that for the compiled query."

209

(bind ((lexical-variables (lexical-variables-of query)))

210

(if (contradictory-p query)

211

`(lambda ,lexical-variables

212

(declare (ignorable ,@lexical-variables))

213

,(empty-result query))

214

(bind ((substitutions (generate-persistent-object-substitutions query)))

215

`(lambda ,lexical-variables

216

(declare (ignorable ,@lexical-variables))

217

(let (,@(emit-persistent-object-bindings substitutions))

218

,(substitute-syntax

219

(add-conversion-to-result-type

220

query

221

(add-unique-filter

222

query

223

(add-mapping-for-collects

224

query

225

(add-sorter-for-order-by

226

query

227

(add-filter-for-asserts

228

query

229

`(open-result-set

230

',(result-type-of query)

231

,(partial-eval (sql-select-for-query query) query)))))))

232

substitutions)))))))

233

234

(defun empty-result (query)

235

(ecase (result-type-of query)

236

(list nil)

237

(scroll '(make-instance 'simple-scroll))))

238

239

(defun add-filter-for-asserts (query form)

240

(bind ((variables (query-variables-of query))

241

(asserts (asserts-of query))

242

(prefetchp (prefetchp query)))

243

(with-unique-names (row)

244

(if asserts

245

`(make-filtered-result-set

246

,form

247

(lambda (,row)

248

(let (,@(emit-query-variable-bindings variables row prefetchp))

249

,(emit-ignorable-variables-declaration variables)

250

(and ,@asserts))))

251

form))))

252

253

(defun add-sorter-for-order-by (query form)

254

(bind ((variables (query-variables-of query))

255

(order-by (order-by-of query))

256

(prefetchp (prefetchp query)))

257

(labels ((rename-query-variables (expr suffix)

258

"Adds the SUFFIX to each query variable symbol in EXPR."

259

(sublis (mapcar #L(cons (name-of !1) (concatenate-symbol (name-of !1) suffix))

260

variables)

261

expr))

262

(generate-variable-bindings (row suffix)

263

(rename-query-variables (emit-query-variable-bindings variables row prefetchp)

264

suffix))

265

(generate-lessp-body (order-by)

266

"Builds the body of the lessp predicate."

267

(bind ((lessp (ecase (first order-by) (:asc 'lessp) (:desc 'greaterp)))

268

(expr1 (rename-query-variables (second order-by) "1"))

269

(expr2 (rename-query-variables (second order-by) "2")))

270

(if (null (cddr order-by))

271

`(,lessp ,expr1 ,expr2)

272

(with-unique-names (obj1 obj2)

273

`(let ((,obj1 ,expr1)

274

(,obj2 ,expr2))

275

(or

276

(,lessp ,obj1 ,obj2)

277

(and

278

(equal ,obj1 ,obj2)

279

,(generate-lessp-body (cddr order-by))))))))))

280

(if (and order-by (or (member :asc order-by) (member :desc order-by)))

281

(with-unique-names (row1 row2)

282

`(make-ordered-result-set

283

,form

284

(lambda (,row1 ,row2)

285

(let (,@(generate-variable-bindings row1 "1")

286

,@(generate-variable-bindings row2 "2"))

287

,(generate-lessp-body order-by)))))

288

form))))

289

290

(defun add-mapping-for-collects (query form)

291

(bind ((variables (query-variables-of query))

292

(collects (collects-of query))

293

(prefetchp (prefetchp query)))

294

(with-unique-names (row)

295

`(make-mapped-result-set

296

,form

297

(lambda (,row)

298

(let (,@(emit-query-variable-bindings variables row prefetchp))

299

,(emit-ignorable-variables-declaration variables)

300

(list ,@collects)))))))

301

302

(defun add-unique-filter (query form)

303

(if (uniquep query)

304

`(make-unique-result-set ,form)

305

form))

306

307

(defun add-conversion-to-result-type (query form)

308

(ecase (result-type-of query)

309

(list `(to-list ,form ,(flatp query)))

310

(scroll `(to-scroll ,form))))

311

312

(defun emit-query-variable-bindings (variables row prefetchp)

313

(iter (for variable in variables)

314

(for slots = (when prefetchp (prefetched-slots-for variable)))

315

(for column-count = (reduce '+ slots

316

:key 'column-count-of

317

:initial-value (length +oid-column-names+)))

318

(for i initially 0 then (+ i column-count))

319

(collect `(,(name-of variable) (cache-object-with-prefetched-slots ,row ,i ',slots)))))

320

321

(defun emit-ignorable-variables-declaration (variables)

322

`(declare (ignorable ,@(mapcar 'name-of variables))))

323

324

(defun generate-persistent-object-substitutions (query)

325

(bind ((objects (collect-persistent-object-literals query))

326

(variables (mapcar #L(gensym (symbol-name (class-name (class-of !1)))) objects)))

327

(mapcar 'cons objects variables)))

328

329

(defun emit-persistent-object-bindings (substitutions)

330

(mapcar #L(`(,(cdr !1) (load-instance ,(car !1)))) substitutions))

331

332

;;;;---------------------------------------------------------------------------

333

;;;; Transformations

334

;;;;

335

(defmethod transform-query ((compiler simple-query-compiler) (query simple-query))

336

"Transforms the QUERY by pushing down the asserts to the SQL query."

337

(macroexpand-query query)

338

(parse-query query)

339

(normalize-query query)

340

(infer-types query)

341

(introduce-joined-variables query)

342

(partial-eval-asserts query)

343

(when (not (contradictory-p query))

344

(let ((*suppress-alias-names* (simple-purge-p query)))

345

(build-sql query)))

346

query)

347

348

(defun macroexpand-query (query)

349

"Expands query macros in QUERY."

350

(setf (asserts-of query)

351

(mapcar 'query-macroexpand (asserts-of query))))

352

353

(defun parse-query (query)

354

(bind ((variables (get-variables query)))

355

(setf (asserts-of query) (mapcar #L(parse-query-form !1 variables) (asserts-of query)))

356

(setf (action-args-of query) (mapcar #L(parse-query-form !1 variables) (action-args-of query)))

357

(setf (order-by-of query) (iter (for (dir expr) on (order-by-of query) by 'cddr)

358

                                     (nconcing (list dir (parse-query-form expr variables)))))))

359

360

(defun normalize-query (query)

361

(setf (asserts-of query)

362

(mappend #L(conjuncts-of

363

(simplify-boolean-syntax

364

(normalize-syntax

365

(partial-eval !1 query))))

366

(asserts-of query))))

367

368

(defun conjuncts-of (syntax)

369

"Return a list of the conjuncts in SYNTAX."

370

(pattern-case syntax

371

(#M(macro-call :macro and) (args-of syntax))

372

(#M(literal-value :value #t) nil)

373

(?otherwise (list syntax))))

374

375

(defgeneric normalize-syntax (syntax)

376

(:documentation "Normalizes type asserts to (typep ...) forms to ease further processing:

377

(typep <object> '<class-name>) -> (typep <object> <class>)

378

(subtypep (class-of <obj>) '<class-name>) -> (typep <object> <class>)

379

(subtypep (class-of <obj>) <type>) -> (typep <object> <type>)

380

381

if the assoc is 1-1

382

(eq (<primary-assoc-end-accessor> <obj1>) <obj2>) ->

383

                                            (eq (secondary-assoc-end-accessor <obj2>) <obj1>)")

384

385

(:method (syntax)

386

syntax)

387

(:method ((form compound-form))

388

(setf (operands-of form)

389

(mapcar 'normalize-syntax (operands-of form)))

390

form)

391

(:method ((call function-call))

392

(call-next-method)

393

(pattern-case call

394

(#M(function-call :fn typep

395

                                :args (?obj #M(literal-value :value (?is ?class persistent-class-p))))

396

call)

397

(#M(function-call :fn typep

398

                                :args (?obj #M(literal-value :value (?is ?name persistent-class-name-p))))

399

(setf (second (args-of call)) (make-literal-value :value (find-class ?name)))

400

call)

401

(#M(function-call :fn subtypep

402

                                :args (#M(function-call :fn class-of :args (?object))

403

                                         #M(literal-value :value (?is ?name persistent-class-name-p))))

404

(make-function-call :fn 'typep

405

:args (list ?object

406

                                                 (make-literal-value :value (find-class ?name)))))

407

(#M(function-call :fn subtypep

408

                                :args (#M(function-call :fn class-of :args (?object)) ?type))

409

(make-function-call :fn 'typep :args (list ?object ?type)))

410

;; TODO reverse 1-1 association-end

411

(?otherwise

412

call))))

413

414

(defun introduce-joined-variables (query)

415

(mapc #L(introduce-joined-variables-for !1 query) (asserts-of query))

416

(mapc #L(introduce-joined-variables-for !1 query) (action-args-of query))

417

(mapc #L(when (syntax-object-p !1) (introduce-joined-variables-for !1 query)) (order-by-of query)))

418

419

(defgeneric introduce-joined-variables-for (syntax query)

420

(:documentation "Substitutes the arguments of slot accessor forms with joined variables.")

421

;; atoms, unparsed

422

(:method (syntax query)

423

(values))

424

;; recurse on compound forms

425

(:method ((syntax compound-form) query)

426

(mapc #L(introduce-joined-variables-for !1 query) (operands-of syntax)))

427

;; slot access -> ensure that arg is a query variable with the correct type

428

(:method ((access slot-access) query)

429

(call-next-method)

430

(when (association-end-access-p (arg-of access))

431

(setf (arg-of access)

432

(joined-variable-for-association-end-access query (arg-of access))))

433

(when (slot-of access)

434

(setf (arg-of access)

435

                    (ensure-type query (arg-of access) (slot-definition-class (slot-of access)))))

436

(values)))

437

438

(defun partial-eval-asserts (query)

439

(setf (asserts-of query)

440

(mapcar #L(partial-eval !1 query) (asserts-of query))))

441

442

(defun contradictory-p (query)

443

(is-false-literal

444

(simplify-boolean-syntax

445

(make-macro-call :macro 'and :args (asserts-of query)))))

446

447

(defun build-sql (query)

448

"Converts assert conditions and order by specifications to SQL."

449

(iter (for variable in (query-variables-of query))

450

(when (joined-variable-p variable)

451

(add-where-clause query (sql-join-condition-for-joined-variable variable))))

452

(setf (asserts-of query)

453

(iter (for condition in (asserts-of query))

454

(bind (((values sql success) (transform-to-sql condition)))

455

(if success

456

(add-where-clause query sql)

457

(collect condition)))))

458

(bind ((new-order-by (iter (for (dir expr) on (order-by-of query) by 'cddr)

459

                              (bind (((values sort-key success) (transform-to-sql expr))

460

                                     (ordering (ecase dir (:asc :ascending) (:desc :descending))))

461

(if success

462

                                    (collect `(sql-sort-spec :sort-key ,sort-key :ordering ,ordering))

463

(leave))))))

464

(when new-order-by

465

(setf (order-by-of query) new-order-by))))

466

467

;;;----------------------------------------------------------------------------

468

;;; Optimize

469

;;;

470

(defmethod optimize-query ((compiler simple-query-compiler) syntax)

471

"Optimize the compiled form."

472

;(simplify-class-references syntax)

473

;(partial-eval syntax)

474

syntax)

475

476

(defun simplify-class-references (syntax)

477

(pattern-case syntax

478

(#M(function-call :fn find-class

479

:args (#M(function-call :fn name-of

480

                                               :args ((? and ?inner #M(function-call :fn class-of

481

                                                                                     :args (?object)))))))

482

(simplify-class-references ?inner))

483

(#M(compound-form)

484

(setf (operands-of syntax)

485

(mapcar 'simplify-class-references (operands-of syntax)))

486

syntax)

487

(?otherwise

488

syntax)))

489

490

491

;;;----------------------------------------------------------------------------

492

;;; SQL mapping

493

;;;

494

(defun transform-to-sql (condition)

495

"Transforms the CONDITION of an assert to an SQL expression."

496

(bind ((sql nil)

497

(success #f))

498

(catch 'sql-map-failed

499

(setf sql (syntax-to-sql condition))

500

(setf success #t))

501

(values sql success)))

502

503

(defun sql-map-failed ()

504

(throw 'sql-map-failed nil))

505

506

507

(defgeneric syntax-to-sql (syntax)

508

(:documentation "Maps a lisp form to SQL.")

509

510

(:method (syntax)

511

(if (free-of-query-variables-p syntax)

512

syntax

513

(sql-map-failed)))

514

515

(:method ((literal literal-value))

516

(literal-to-sql (value-of literal) (xtype-of literal) literal))

517

518

(:method ((variable lexical-variable))

519

`(value->sql-literal ,(name-of variable) ,(backquote-type-syntax (xtype-of variable))))

520

521

(:method ((variable query-variable))

522

(sql-id-column-reference-for variable))

523

524

(:method ((access slot-access))

525

(slot-access-to-sql (accessor-of access) (arg-of access) access))

526

527

(:method ((call function-call))

528

(bind ((fn (fn-of call))

529

(args (args-of call)))

530

(function-call-to-sql fn (length args) (first args) (second args) call)))

531

532

(:method ((call macro-call))

533

(bind ((macro (macro-of call))

534

(args (args-of call)))

535

(macro-call-to-sql macro (length args) (first args) (second args) call))))

536

537

(defgeneric literal-to-sql (value type literal)

538

(:documentation "Maps a literal value to SQL.")

539

540

(:method (value type literal)

541

(cond

542

((keywordp value) value)

543

((syntax-object-p type) `(value->sql-literal ,literal ,(backquote-type-syntax type)))

544

(t (value->sql-literal value type)))))

545

546

(defgeneric slot-access-to-sql (accessor arg access)

547

(:method (accessor arg access)

548

(if (free-of-query-variables-p access)

549

`(value->sql-literal ,access ,(backquote-type-syntax (xtype-of access)))

550

(sql-map-failed)))

551

552

(:method (accessor (variable query-variable) (access slot-access))

553

;; slot accessor

554

(bind ((slot (slot-of access)))

555

(if (and slot (persistent-slot-p slot))

556

(sql-column-reference-for slot variable)

557

(sql-map-failed))))

558

559

(:method (accessor (variable query-variable) (access association-end-access))

560

;; association-end accessor

561

(if (association-end-of access)

562

(bind ((association-end (association-end-of access))

563

(association (association-of association-end)))

564

(ecase (association-kind-of association)

565

(:1-1

566

(if (primary-association-end-p association-end)

567

(sql-column-reference-for association-end variable)

568

                         (sql-subselect-for-secondary-association-end association-end variable)))

569

(:1-n

570

(if (to-one-association-end-p association-end)

571

(sql-column-reference-for association-end variable)

572

                         (sql-subselect-for-secondary-association-end association-end variable)))

573

(:m-n

574

(sql-subselect-for-m-n-association association-end variable))))

575

(sql-map-failed))))

576

577

578

(defgeneric function-call-to-sql (fn n-args arg1 arg2 call)

579

580

(:method (fn n-args arg1 arg2 call)

581

(cond

582

;; (<aggregate-fn> (<n-ary-association-end-accessor> <query-var>))

583

;; e.g. (length (messages-of topic)) -->

584

              ;;         (select count(_m.id) from _message _m where _m.topic_id = _topic.id)

585

((and (sql-aggregate-function-name-p fn) (= n-args 1)

586

(association-end-access-p arg1) (association-end-of arg1)

587

(query-variable-p (arg-of arg1)))

588

(ecase (association-kind-of (association-of (association-end-of arg1)))

589

(:1-1

590

(sql-map-failed))

591

(:1-n

592

(sql-aggregate-subselect-for-variable

593

(sql-aggregate-function-for fn)

594

(association-end-of arg1)

595

(arg-of arg1)))

596

(:m-n

597

(sql-aggregate-subselect-for-m-n-association-end

598

(sql-aggregate-function-for fn)

599

(association-end-of arg1)

600

(arg-of arg1)))))

601

;; eq,eql and friends: compare with NULL can be true

602

((member fn '(eq eql equal))

603

(sql-equal

604

(syntax-to-sql arg1)

605

(syntax-to-sql arg2)

606

:check-nils (and (maybe-null-subtype-p (xtype-of arg1))

607

(maybe-null-subtype-p (xtype-of arg2)))))

608

((eq fn 'string=)

609

(sql-string=

610

(syntax-to-sql arg1)

611

(syntax-to-sql arg2)

612

:check-nils (and (maybe-null-subtype-p (xtype-of arg1))

613

(maybe-null-subtype-p (xtype-of arg2)))))

614

;; (<fn> <arg> ...), where <fn> has SQL counterpart

615

;; e.g. (+ 1 2) --> (1 + 2)

616

((sql-operator-p fn)

617

`(funcall ',(sql-operator-for fn) ,@(mapcar 'syntax-to-sql (args-of call))))

618

;; When the function call does not depend on query variables

619

;; evaluate it at runtime and insert its value into the SQL query.

620

;; The persistent-objects in the value are converted to object ids.

621

((every 'free-of-query-variables-p (args-of call))

622

`(value->sql-literal ,call ,(backquote-type-syntax (xtype-of call))))

623

;; Otherwise the assert containing the function call cannot be mapped to SQL.

624

(t

625

(sql-map-failed))))

626

627

;; member form -> in (ignore keyword args, TODO)

628

(:method ((fn (eql 'member)) n-args arg1 arg2 call)

629

(cond

630

((literal-value-p arg2)

631

(if (null (value-of arg2))

632

(sql-false-literal)

633

`(sql-in ,(syntax-to-sql arg1) ,(syntax-to-sql arg2))))

634

((free-of-query-variables-p arg2)

635

`(if (null ,(unparse-query-syntax arg2))

636

(sql-false-literal)

637

,(unparse-query-syntax `(sql-in ,(syntax-to-sql arg1) ,(syntax-to-sql arg2)))))

638

(t `(sql-in ,(syntax-to-sql arg1) ,(syntax-to-sql arg2)))))

639

640

;; (member <object> (<association-end-accessor> <query-variable>))

641

;; e.g. (member m1 (messages-of topic)) --> (_m1.topic_id = _topic.id)

642

   (:method ((fn (eql 'member)) (n-args (eql 2)) (object query-variable) (access association-end-access) call)

643

;; member form -> join

644

;; example:

645

;; (member m (messages-of t)) -> m.topic_id = t.id

646

(if (or (not (query-variable-p (arg-of access)))

647

(not (association-end-of access)))

648

(call-next-method)

649

(bind ((association-end (association-end-of access))

650

(variable (arg-of access))

651

(association (association-of association-end)))

652

(ecase (association-kind-of association)

653

(:1-1

654

(sql-map-failed))

655

(:1-n

656

(sql-join-condition-for object variable association-end))

657

(:m-n

658

                     (sql-join-condition-for-m-n-association object variable association-end))))))

659

660

;; eq form -> join

661

;; examples:

662

;; (eq (topic-of message) topic) -> message.topic_id = topic.id

663

;; (eq (wife-of man) woman) -> man.wife_id = woman.id

664

;; (eq (husband-of woman) man) -> man.wife_id = woman.id

665

(:method ((fn (eql 'eq)) (n-args (eql 2)) (access association-end-access) object call)

666

667

(if (not (association-end-of access))

668

(sql-map-failed)

669

(bind ((association-end (association-end-of access))

670

(other-end (other-association-end-of association-end))

671

(variable (arg-of access))

672

(association (association-of association-end)))

673

(ecase (association-kind-of association)

674

(:1-1

675

(if (primary-association-end-p association-end)

676

(call-next-method)

677

(syntax-to-sql

678

(make-function-call ;; reverse

679

:fn fn

680

                           :args (list (make-association-end-access :association-end other-end

681

                                                                    :accessor (first (slot-definition-readers (first (direct-slots-of other-end))))

682

                                                                    :args (list object))

683

variable)))))

684

(:1-n

685

(call-next-method))

686

(:m-n

687

(sql-map-failed))))))

688

689

(:method ((fn (eql 'eq)) (n-args (eql 2)) object (access association-end-access) call)

690

(function-call-to-sql fn 2 access object call))

691

692

;; typep form

693

;; example:

694

;; (typep o #<class user>) -> exists(select 1 from user u where u.id = o.id)

695

(:method ((fn (eql 'typep)) (n-args (eql 2)) (variable query-variable) (type literal-value) call)

696

(if (persistent-class-p (value-of type))

697

(sql-exists-subselect-for-variable variable (value-of type))

698

(call-next-method)))

699

)

700

701

(defgeneric macro-call-to-sql (macro n-args arg1 arg2 call)

702

(:method (macro n-args arg1 arg2 call)

703

(cond

704

((sql-operator-p macro)

705

`(funcall ',(sql-operator-for macro) ,@(mapcar 'syntax-to-sql (args-of call))))

706

((every 'free-of-query-variables-p (args-of call))

707

`(value->sql-literal ,call ,(backquote-type-syntax (xtype-of call))))

708

(t

709

(sql-map-failed)))))

710

711

(defun free-of-query-variables-p (syntax)

712

(typecase syntax

713

(query-variable #f)

714

(unparsed-form (free-of-query-variables-p (form-of syntax)))

715

(compound-form (every 'free-of-query-variables-p (operands-of syntax)))

716

(cons (and (free-of-query-variables-p (car syntax))

717

(free-of-query-variables-p (cdr syntax))))

718

(otherwise #t)))

719

720

;;;----------------------------------------------------------------------------

721

;;; Helpers

722

;;;

723

724

(defun joined-variable-for-association-end-access (query access)

725

(ensure-joined-variable

726

query

727

(arg-of access)

728

(association-end-of access)

729

(normalized-type-for* (xtype-of access))))

730

731

(defun ensure-joined-variable (query object association-end type)

732

(or (and (query-variable-p object) (eq (xtype-of object) type) object)

733

(find-joined-variable-by-definition query object association-end type)

734

(make-new-joined-variable query object association-end type)))

735

736

(defun ensure-type (query object type)

737

(if (eq (xtype-of object) +unknown-type+)

738

(progn (setf (xtype-of object) type) object)

739

(or (and (eq (xtype-of object) type) object)

740

(find-joined-variable-by-definition query object nil type)

741

(make-new-joined-variable query object nil type))))

742

743

(defun find-joined-variable-by-definition (query object association-end type)

744

(find-if

745

#L(and (typep !1 'joined-variable)

746

(eq association-end (association-end-of !1))

747

(equal object (object-of !1))

748

(eq (xtype-of !1) type))

749

(query-variables-of query)))

750

751

(defun make-new-joined-variable (query object association-end type)

752

"Creates a new joined variable."

753

(bind ((name (generate-joined-variable-name type))

754

(variable (make-joined-variable :name name :object object

755

                                          :association-end association-end :xtype type)))

756

(add-joined-variable query variable)

757

variable))

758

759

(defun generate-joined-variable-name (type)

760

"Generates a name for a joined variable of type TYPE."

761

(typecase type

762

(persistent-class (gensym (symbol-name (class-name type))))

763

(symbol (gensym (symbol-name type)))

764

(otherwise (gensym "joined"))))

765

766

(defgeneric collect-persistent-object-literals (element &optional result)

767

(:method ((query simple-query) &optional result)

768

(collect-persistent-object-literals

769

(order-by-of query)

770

(collect-persistent-object-literals

771

(action-args-of query)

772

(collect-persistent-object-literals

773

(asserts-of query)

774

result))))

775

776

(:method ((element t) &optional result)

777

result)

778

779

(:method ((object persistent-object) &optional result)

780

(adjoin object result))

781

782

(:method ((literal literal-value) &optional result)

783

(collect-persistent-object-literals (value-of literal) result))

784

785

(:method ((cons cons) &optional result)

786

(collect-persistent-object-literals

787

(car cons)

788

(collect-persistent-object-literals

789

(cdr cons)

790

result)))

791

792

(:method ((form unparsed-form) &optional result)

793

(collect-persistent-object-literals (form-of form) result))

794

795

(:method ((form compound-form) &optional result)

796

(collect-persistent-object-literals (operands-of form) result)))