Coverage report: /development/source/library/org/datagraph/spocq-shard/src/odbc/sql/sparql-query-sql.lisp

Kind	Covered	All	%
expression	16	1235	1.3
branch	0	94	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.datagraph.spocq.implementation; -*-

2

3

(in-package :org.datagraph.spocq.implementation)

4

5

;;; (load #p"LIBRARY:org;datagraph;spocq;src;core;encoding;sparql-query-sql.lisp")

6

;;; (load #p"patches/sparql-query-sql.lisp")

7

;;; (asdf:operate 'asdf:load-op 'clsql-odbc)

8

;;; (sb-ext:save-lisp-and-die "sbcl-spocq-odbc.core")

9

;;; (clsql:connect '("stage" "james" "test") )

10

;;;

11

12

;;; references

13

 ;;; paaulhemus:2008: https://www.w3.org/2008/07/MappingRules/StemMapping : discussion of translation in principle

14

;;; chebotko.2009: http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.157.5733&rep=rep1&type=pdf

15

 ;;; antoniogarotta:r2rml: https://antoniogarrote.wordpress.com/2011/01/10/translating-sparql-queries-into-sql-using-r2rml/

16

;;; queztal : https://github.com/Quetzal-RDF/quetzal : based on a flattened graph model

17

 ;;; chorcho.2014: https://www.researchgate.net/profile/Oscar_Corcho/publication/261961018_Formalisation_and_experiences_of_R2RML-based_SPARQL_to_SQL_query_translation_using_morph/links/543ff0b30cf2fd72f99dc8cf.pdf

18

;;; sequeda.2012: http://apps.cs.utexas.edu/tech_reports/reports/tr/TR-2078.pdf

19

;;; utilities

20

;;; https://github.com/AccelerationNet/clsql-helper

21

;;;

22

23

(:documentation "sse -> sql rewriting for a sparql subset"

24

"Generate an SQL request text from the SSE for a SPARQL query.

25

operates as a simple recursive descent re-writer to transform the SPARQL SSE into CLSQL SQL

26

form instances, leaving the subsequent encoding step of the SQL expression to CLSQL.

27

nb. SXQL was tried, but it handles just the SQL generation, but not the db interface.

28

29

The translation involves several aspects

30

- resource-api definitions are associated with the type(s) extracted from a BGP

31

(see compute-bgp-sql), each of which contains the relation between properties and SQL

32

attributes for that class (see resource-api-*-attribute)

33

   - a service clause which specifies an 'odbc' resource, that is a repository which is an hydra:|ODBCView|

34

location, invokes repository-sparql-sql, which relies on compute-sparql-sql to translate a

35

SPARQL expression. (nb. this needs to be generalized to other SQL sources)

36

- an optional BGP macro-expansion module to segment the bgp by type and, given a graph context,

37

to transform it into an odbc service operation.

38

   - the core translation operator, compute-sparql-sql, dispatches on the operator, deconstructs the expression

39

components, trnalsates sub-expressions and combines them into CLSQL SQOL form instances.

40

41

   In order to allow for varied SQL database organizations, tables are reified as instance which combine

42

   schema and table name proper. This permits to use the qualified name in the FROM clause, but to compose

43

attribute references of just the simple table name and the column name.

44

45

   The process is straight forward recursive-descent translation and subsequent reconstruction by combination.

46

   in order to manage variable->attribute corespondence, the process carries attribute definition environments along with the translations.

47

each operator produces or combines these according to its algebra.

48

   at the leaves - bgp, values, and bind forms, the environment is created with the attributes introduced by the respective translation.

49

at this lowest level, the select is generated with an alias.

50

   in the case of bgp, the attributes are computed from the bgp-specific api, with fall-back to the repository api.

51

for autonomous bindings, the api is just that associated with the repository.

52

in the case of combination operators, the environments from the constitutent translations are merged.

53

   the merge operation retains all definitions, in order to premit unambiguous mapping back from attribute to variable.

54

   if the operator performs projection, that may reduce the map set to just those variables which are projected.

55

56

   each leaf environment is provided its own alias, which is also incorporated into the attributes definitions.

57

this qualification is used universally, unchanged, in order that all references are unambiguous.

58

59

")

60

61

;;; SELECT city FROM user WHERE (firstName, lastName) IN (('a', 'b'), ('c', 'd'));

62

;;; odbc

63

64

65

(defmethod macroexpand-bgp-phase ((phase (eql :odbc)) body (env t))

66

"Perform a class-based segmentation to recognize implicit api references, but also

67

recognize a containing graph to apply to any untyped statements.

68

Combine both reference forms in nested joins.

69

If the raph is present, transform it into a service call, otherwise leave the individual

70

forms to be sip-processed based on the individual api reference."

71

;; use just the latest declaration

72

(macroexpand-bgp-odbc-phase body (first (declaration-information 'spocq.e:base-dimensions env))))

73

74

75

(defun macroexpand-bgp-odbc-phase (body base-dimension-declarations)

76

(multiple-value-bind (segments untyped-statements)

77

(segment-dependencies body base-dimension-declarations)

78

;; recognize a combination of an explicit graph and types based table delegation

79

(let* ((graph (second (assoc 'spocq.a:|graph| body)))

80

(graph-api-definition (when (and graph untyped-statements) (resource-api graph)))

81

(graph-api-reference (when graph-api-definition

82

                                   (clone-instance-as graph-api-definition 'resource-reference

83

:id graph

84

                                                      :pattern untyped-statements)))

85

(reference-segments (if segments

86

                                    (if graph-api-reference (append segments (list graph-api-reference)) segments)

87

(list graph-api-reference))))

88

(cond (reference-segments

89

(let* ((location (first (resource-api-templates (first segments))))

90

(field (loop with form = (pop segments)

91

for segment in segments

92

do (setf form `(spocq.a:|join| ,form ,segment))

93

finally (return form)))

94

(dimensions (expression-dimensions body)))

95

(if graph-api-reference

96

`(spocq.a:|service| ,location

97

(spocq.a:|select| ,field ,dimensions))

98

field)))

99

(t

100

;; given no segment, then return the original to indicate no expansion.

101

body)))))

102

103

;;; sql

104

105

(defpackage :org.datagraph.spocq.sql

106

(:use )

107

(:nicknames :ssql)

108

(:export :join

109

:left-join

110

:select

111

:format-sql))

112

113

(defparameter *org.datagraph.spocq.sql* (find-package :org.datagraph.spocq.sql))

114

(defparameter *sql-translation-mode* :execute

115

":execute signals an error for unsupported forms

116

:debug warns and returns nil or some sub-translation

117

:translate translates silently")

118

119

(defun sql-form-p (form)

120

(and (typep form '(cons symbol t))

121

(eql (symbol-package (first form)) *org.datagraph.spocq.sql*)))

122

;;; (sql-form-p '(ssql:join nil nil))

123

;;; (sql-form-p '(spocq.a:|join| nil nil))

124

;;; (sql-form-p "asdf")

125

126

(defparameter *sql-class* nil)

127

(defparameter *sql-graph* nil)

128

(defparameter *sql-sparql-form* nil)

129

(defparameter *sql-extensions* (make-registry :weakness :key))

130

(defparameter *sql-environment* nil)

131

132

(defclass sql-environment ()

133

((as :initform (gentemp "AS-") :initarg :as :reader sql-environment-as)

134

(map :initform nil :initarg :map :accessor sql-environment-map)

135

(av-map :initform nil :initarg :av-map :accessor sql-environment-av-map)

136

(constituents :initform nil :initarg :constituents :accessor sql-environment-constituents)))

137

138

(defmethod print-object ((object sql-environment) stream)

139

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

140

(format stream "~s -> ~s"

141

(mapcar #'first (sql-environment-map object))

142

(mapcar #'first (sql-environment-av-map object)))))

143

144

(defun make-sql-environment (&rest args)

145

(declare (dynamic-extent args))

146

(apply #'make-instance 'sql-environment args))

147

148

(defun copy-sql-environment (env &key (as (sql-environment-as env))

149

(map (sql-environment-map env))

150

(constituents (sql-environment-constituents env))

151

(av-map (sql-environment-av-map env)))

152

(make-instance 'sql-environment :as as :map map :av-map av-map :constituents constituents))

153

154

(defgeneric sql-attribute-variable (attribute &optional environment)

155

(:method ((attribute string) &optional (environment *sql-environment*))

156

(rest (assoc attribute (sql-environment-av-map environment) :test #'string-equal))))

157

158

(defun sql-variable-attribute (variable &optional (environment *sql-environment*))

159

"map back from the attribute to the respective variable"

160

(let ((definition (assoc variable (sql-environment-map environment))))

161

(if definition

162

(rest definition)

163

variable)))

164

165

(defun (setf sql-variable-attribute) (attribute variable &optional (e *sql-environment*))

166

(push (cons variable attribute) (sql-environment-map e))

167

(let ((output (clsql-sys::sql-output attribute))

168

(name (slot-value attribute 'CLSQL-SYS::NAME)))

169

(push (cons output variable) (sql-environment-av-map e))

170

(push (cons name variable) (sql-environment-av-map e)))

171

attribute)

172

173

(defgeneric combine-sql-environments (operator environment1 environment2)

174

(:method ((operator t) (e1 null) (e2 t))

175

e2)

176

(:method ((operator t) (e1 t) (e2 null))

177

e1)

178

(:method ((operator t) (e1 sql-environment) (e2 sql-environment))

179

(make-instance 'sql-environment

180

:map (combine-sql-environments operator (sql-environment-map e1) (sql-environment-map e2))

181

:av-map (combine-sql-environments operator (sql-environment-av-map e1) (sql-environment-av-map e2))

182

:constituents (append (sql-environment-constituents e1) (sql-environment-constituents e2))))

183

184

(:method ((operator t) (e1 cons) (e2 cons))

185

;; the default method just appens the definitions

186

(append e1 e2)))

187

188

189

(defun sql-string (string)

190

(clsql:sql-expression :string string))

191

(defun sql-attribute (name &optional (table nil))

192

"use string-value names, otherwise the table causes clsql to try to locate a class"

193

(clsql:sql-expression :attribute (etypecase name

194

(symbol (symbol-name name))

195

(string name))

196

:table (etypecase table

197

(null nil)

198

(symbol (string table))

199

(string table))))

200

(defun sql-variable (name)

201

(let ((attr (sql-variable-attribute name)))

202

(or attr

203

(make-instance 'clsql:sql-variable :name name))))

204

205

(defun sql-ident-table (name)

206

(destructuring-bind (p1 &optional p2) (split-string name #(#\.))

207

(make-instance 'clsql-sys:sql-ident-table :name (or p2 p1) :table-schema (when p2 p1))))

208

209

(defun sql-ident-table-name (ident-table)

210

(with-slots (clsql-sys:name) ident-table

211

clsql-sys:name))

212

213

(defun sql-ident-qualified-table-name (ident-table)

214

(with-slots (clsql-sys:name clsql-sys::schema) ident-table

215

     (flet ((edi (n) ;; the etypecase is in sql-escape too

216

(clsql-sys::escaped-database-identifier n clsql-sys:*default-database*)))

217

(if clsql-sys::schema

218

(concatenate 'string (edi clsql-sys::schema) "." (edi clsql-sys:name))

219

(edi clsql-sys:name)))))

220

221

(defun compute-sql-view-name ()

222

(let ((effective-location (or *sql-class* *sql-graph* (error "no view visible"))))

223

(iri-local-part effective-location)))

224

225

(defgeneric ssql:format-sql (stream object &optional colon at)

226

(:method ((stream t) (expression cons) &optional colon at)

227

(declare (ignore colon at))

228

(write-sparql-sql expression :stream stream)))

229

230

(defun write-sparql-sql (expression &key (stream *standard-output*))

231

"translate a sparql sse into an sql text expression"

232

(let* ((*repository* (or *repository* (make-instance 'clsql-sys::generic-database)))

233

(sql (repository-sparql-sql *repository* expression)))

234

(write-string (clsql-sys::sql-output sql *repository*) stream)))

235

236

(let ((sql-operator-map (make-hash-table)))

237

(defun sparql-sql-operator (sparql-op) (gethash sparql-op sql-operator-map))

238

(defun (setf sparql-sql-operator) (sql-op sparql-op) (setf (gethash sparql-op sql-operator-map) sql-op))

239

(loop for (sparql-op sql-op) in '((spocq.a:|regex| LIKE))

240

do (setf (sparql-sql-operator sparql-op) sql-op)))

241

242

(defgeneric compute-sql-expression (expression)

243

(:method ((term t))

244

(sql-string (with-output-to-string (stream) (encode-ssf-object term stream))))

245

(:method ((term string))

246

term)

247

(:method ((term number))

248

term)

249

(:method ((attribute CLSQL-SYS:SQL-IDENT-ATTRIBUTE))

250

;; when already translated

251

attribute)

252

(:method ((variable CLSQL-SYS:SQL-variable))

253

;; when already translated

254

variable)

255

(:method ((term symbol))

256

(if (variable-p term)

257

(sql-variable term)

258

(let ((uri-namestring (symbol-uri-namestring term)))

259

(cond (uri-namestring

260

(sql-string uri-namestring))

261

(t

262

                  (sql-string (with-output-to-string (stream) (encode-ssf-object term stream))))))))

263

(:method ((term spocq:iri))

264

(sql-string (spocq:iri-lexical-form term)))

265

(:method ((expression cons))

266

(cond ((relational-sse-form-p expression)

267

(destructuring-bind (op . arguments) expression

268

(case op

269

(spocq.a:|in|

270

(clsql:sql-operation :in arguments))

271

(spocq.a:|notin|

272

                 (clsql:sql-operation :not (compute-sql-expression (cons 'spocq.a:|in| arguments))))

273

(spocq.a:|!=|

274

(clsql:sql-operation :<>

275

(compute-sql-expression (first arguments))

276

                                      (compute-sql-expression (second arguments))))

277

(t

278

(clsql:sql-operation op

279

(compute-sql-expression (first arguments))

280

                                      (compute-sql-expression (second arguments)))))))

281

((conditional-sse-form-p expression)

282

(destructuring-bind (op . arguments) expression

283

(case op

284

(spocq.a:|exprlist|

285

(compute-sql-expression `(spocq.a:|&&| ,@arguments)))

286

((spocq.a:|not| spocq.a:|!|)

287

(clsql:sql-operation :not (compute-sql-expression (first arguments))))

288

(t

289

;; permit multiple arguments by unrolling into binary comparisons

290

(cond ((rest arguments)

291

(clsql:sql-operation (ecase op

292

                                               ((spocq.a:|and| spocq.a:|&&|) :and)

293

                                               ((spocq.a:|or| spocq.a:\|\|) :or))

294

                                             (compute-sql-expression (first arguments))

295

                                             (compute-sql-expression (cons op (rest arguments)))))

296

(t

297

(compute-sql-expression (first arguments))))))))

298

((arithmetic-sse-form-p expression)

299

(destructuring-bind (op . arguments) expression

300

(cond ((rest arguments)

301

(clsql:sql-operation op

302

                                          (compute-sql-expression (first arguments))

303

                                          (compute-sql-expression (second arguments))))

304

(t

305

(clsql:sql-operation op (compute-sql-expression (first arguments)))))))

306

((eq (first expression) 'spocq.a:|exprlist|)

307

(compute-sql-expression `(spocq.a:|&&| ,@(rest expression))))

308

((built-in-sse-form-p expression)

309

(destructuring-bind (op . arguments) expression

310

(compute-sparql-builtin-sql op arguments)))

311

((functional-sse-form-p expression)

312

(destructuring-bind (op . arguments) expression

313

;; try and see

314

(apply #'clsql:sql-operation op (mapcar #'compute-sql-expression arguments))))

315

(t

316

(loop for element in expression collect (compute-sql-expression element))))))

317

318

(defgeneric compute-sparql-builtin-sql (operator args)

319

(:method ((operator t) args)

320

;; if the operator translates 1-1, use it. otherwise signal an error if executing

321

322

                                              spocq.a:|concat| (spocq.a:|strlen| . :length)

323

(spocq.a:|ucase| . :upper)

324

(spocq.a:|lcase| . :lower)

325

spocq.a:|day|

326

spocq.a:|month|

327

spocq.a:|now|

328

spocq.a:|year|

329

spocq.a:|hours|

330

spocq.a:|minutes|

331

spocq.a:|seconds|

332

(spocq.a:|str| . :concat)

333

)

334

if (eq entry operator) return entry

335

                           if (and (consp entry) (eq (first entry) operator)) return (rest entry)

336

finally (progn

337

                                     (funcall (ecase *sql-translation-mode* (:debug #'warn) (:execute #'error)

338

(:translate #'list))

339

                                              "Operator has no sql equivalent: ~s." operator)

340

(return operator)))))

341

(apply #'clsql:sql-operation sql-operator (mapcar #'compute-sql-expression args))))

342

343

(:method ((operator (eql 'spocq.a:|day|)) args)

344

`("extract" "day" "from" ,(compute-sql-expression (first args))))

345

(:method ((operator (eql 'spocq.a:|hours|)) args)

346

`("extract" "hour" "from" ,(compute-sql-expression (first args))))

347

(:method ((operator (eql 'spocq.a:|minutes|)) args)

348

`("extract" "minute" "from" ,(compute-sql-expression (first args))))

349

(:method ((operator (eql 'spocq.a:|month|)) args)

350

`("extract" "months" "from" ,(compute-sql-expression (first args))))

351

(:method ((operator (eql 'spocq.a:|year|)) args)

352

`("extract" "year" "from" ,(compute-sql-expression (first args))))

353

(:method ((operator (eql 'spocq.a:|seconds|)) args)

354

`("extract" "second" "from" ,(compute-sql-expression (first args))))

355

356

(:method ((operator (eql 'spocq.a:|contains|)) args)

357

(destructuring-bind (value pattern) (mapcar #'compute-sql-expression args)

358

(clsql:sql-operation 'like value pattern)))

359

;; (compute-sparql-function-sql 'spocq.a:|contains| '("asdf...qwer" "q"))

360

(:method ((operator (eql 'spocq.a:|iri|)) args)

361

(destructuring-bind (value) (mapcar #'compute-sql-expression args)

362

value))

363

(:method ((operator (eql 'spocq.a:|uri|)) args)

364

(compute-sparql-builtin-sql 'spocq.a:|iri| args))

365

(:method ((operator (eql 'spocq.a:|regex|)) args)

366

(destructuring-bind (pattern value) (mapcar #'compute-sql-expression args)

367

(clsql:sql-operation 'like pattern (clsql:sql-operation 'concat "%" value))))

368

(:method ((operator (eql 'spocq.a:|strafter|)) args)

369

(call-next-method))

370

(:method ((operator (eql 'spocq.a:|strbefore|)) args)

371

(call-next-method))

372

(:method ((operator (eql 'spocq.a:|strends|)) args)

373

(destructuring-bind (value pattern) (mapcar #'compute-sql-expression args)

374

(clsql:sql-operation 'like value (clsql:sql-operation 'concat "%" pattern))))

375

(:method ((operator (eql 'spocq.a:|strstarts|)) args)

376

(destructuring-bind (value pattern) (mapcar #'compute-sql-expression args)

377

(clsql:sql-operation 'like value (clsql:sql-operation 'concat pattern "%"))))

378

)

379

380

(defgeneric compute-sql-order (order)

381

(:method ((order null))

382

nil)

383

(:method ((order symbol))

384

(compute-sql-expression order))

385

(:method ((order cons))

386

(case (first order)

387

((spocq.a:|asc| spocq.a:|desc|)

388

(list (compute-sql-order (second order)) (first order)))

389

(t

390

(if (or (consp (first order)) (variable-p (first order)))

391

(loop for expression in order

392

collect (compute-sql-order expression))

393

(compute-sql-expression order))))))

394

395

#+(or)

396

(defgeneric find-sql-attribute (context variable)

397

(:method (context variable)

398

(getf (gethash context *sql-extensions*) variable))

399

(:method ((context CLSQL-SYS::SQL-JOIN-EXP) variable)

400

(or (call-next-method)

401

(loop for component in (slot-value context 'clsql-sys::components)

402

for attribute = (find-sql-attribute component variable)

403

when attribute

404

do (return attribute))))

405

(:method ((context CLSQL-SYS:SQL-QUERY-MODIFIER-EXP) variable)

406

(or (call-next-method)

407

(loop for component in (slot-value context 'clsql-sys::components)

408

for attribute = (find-sql-attribute component variable)

409

when attribute

410

do (return attribute))))

411

(:method ((context CLSQL-SYS:SQL-QUERY) variable)

412

(or (call-next-method)

413

(find-sql-attribute (slot-value context 'clsql-sys::where) variable))))

414

415

#+(or)

416

(defun (setf find-sql-attribute) (attribute context variable)

417

(setf (getf (gethash context *sql-extensions*) variable) attribute))

418

419

420

421

;;; sql generation

422

423

(defmethod repository-api ((repository clsql-sys::generic-database))

424

"support the default db as a fall-back for generation"

425

nil)

426

427

(defgeneric repository-sparql-sql (repository sparql-expression)

428

(:method ((repository t) (sparql-expression t))

429

(multiple-value-bind (sql e) (compute-sparql-sql repository sparql-expression)

430

(typecase sql

431

(clsql:sql-query

432

(setf (clsql:sql-ident-table-alias (clsql:select-from sql)) nil)))

433

(values sql e))))

434

435

(defgeneric compute-sparql-sql (repository *sql-sparql-form*)

436

(:method ((repository null) (form t))

437

(compute-sparql-sql (make-instance 'clsql-sys::generic-database) form))

438

#+(or) ;; use a static weak hash table

439

(:method :around ((repository t) (form t))

440

(if *sql-extensions*

441

(call-next-method)

442

(let ((*sql-extensions* (make-hash-table :test 'eq)))

443

(call-next-method))))

444

(:method ((repository t) (*sql-sparql-form* t))

445

(compute-sparql-operator-sql repository (first *sql-sparql-form*) (rest *sql-sparql-form*))))

446

447

448

449

(defgeneric compute-sparql-operator-sql (repository operator arguments)

450

(:documentation "Given an operator and its argument list, compute the equivalent sql expression

451

in the form of a CLSQL expression instance. Proceed by recursive desent, to construct compound

452

expressions. In some cases, structural differences require esplicit rearrangements.")

453

(:method ((repository t) (operator t) arguments)

454

     ;; cath or,s such as construct, describe, quad, table, triple - which should not arise or have no counterpart

455

(error "Operator ~s not supported in SQL . ~s"

456

operator arguments))

457

)

458

459

460

(defmacro def-compute-sql-method (operator lambda-list &body body)

461

`(defmethod compute-sparql-operator-sql (.repository. (operator (eql ',operator)) arguments)

462

,@(when (stringp (first body)) (list (pop body)))

463

(destructuring-bind ,lambda-list (cons .repository. arguments)

464

,@body)))

465

466

467

(def-compute-sql-method spocq.a:|bgp| (repository &rest pattern)

468

"Given a BGP translate it into sql:

469

- partition it per subject/type into distinct selects.

470

- transform each of those into an sql select.

471

- combine them as joins ordered by join cardinality."

472

(let* ((bgp-bindings (assoc 'spocq.a:|bindings| pattern))

473

(bgp-bindings-dimensions (third bgp-bindings))

474

(effective-base-dimensions (union-dimensions bgp-bindings-dimensions

475

                                                       (first (query-dynamic-bindings *query*)))))

476

(multiple-value-bind (resource-references untyped-statements)

477

(segment-dependencies pattern effective-base-dimensions)

478

#+(or) ;; allow no api

479

(assert resource-references ()

480

"no bgp api-references found: ~s" pattern)

481

;; extract the property-variable relation, distinguished by class and join variable.

482

       ;; combine this with the property variable map from the api definition to yield join constraints and

483

;; the relation between sparql variables and sql columns.

484

       ;; return a 'table' description to make this information available to generate select expressions.

485

(let* ((segments (mapcar #'resource-reference-pattern resource-references))

486

(dimensioned-segments (sort (loop for segment in segments

487

for as from 1

488

                                            for bindings = (remove-if-not #'variable-p (compute-pattern-bindings segment) :key #'rest)

489

;; prepare join constraints

490

                                            collect (list :bindings bindings :variables (mapcar #'rest bindings)

491

                                                          :pattern segment

492

                                                          :as (format nil "as~d" as)))

493

                                          #'< :key #'(lambda (ds) (length (getf ds :bindings)))))

494

(*sql-environment* nil)

495

(selects (append (loop for d-segment in dimensioned-segments

496

for pattern = (getf d-segment :pattern)

497

                                 collect (multiple-value-bind (sql sub-env) (compute-bgp-sql repository pattern)

498

                                           (setf *sql-environment* (combine-sql-environments 'spocq.a:|join| *sql-environment* sub-env))

499

sql))

500

(when untyped-statements

501

                                 (multiple-value-bind (sql sub-env) (compute-bgp-sql repository untyped-statements)

502

                                   (setf *sql-environment* (combine-sql-environments 'spocq.a:|join| *sql-environment* sub-env))

503

(list sql))))))

504

(values (if (null (rest selects))

505

(first selects)

506

(let* ((projection-attributes (loop for select in selects

507

                                                     append (CLSQL-SYS:SELECT-SELECTIONS select)))

508

(slice (rest (assoc 'spocq.a:|slice| untyped-statements)))

509

                            (join-constraints (loop for segments on dimensioned-segments by #'cddr

510

                                                for s1 = (first segments)

511

                                                append (when (rest segments)

512

                                                         (loop for s2 on (rest segments) by #'cddr

513

                                                           append (loop for variable in (intersection (getf s1 :variables) (getf s2 :variables))

514

                                                                    collect (let ((s1-binding (rassoc variable (getf s1 :binding)))

515

                                                                                  (s2-binding (rassoc variable (getf s2 :binding))))

516

                                                                              (clsql:sql-operation '=

517

                                                                                                   (sql-attribute s1-binding (getf s1 :as))

518

                                                                                                   (sql-attribute s2-binding (getf s2 :as))))))))))

519

(apply #'clsql:sql-operation 'select

520

(append projection-attributes

521

(cons :from selects)

522

                                      (when join-constraints (cons :where join-constraints))

523

                                      (append (when (first slice) `(:limit ,(first slice)))

524

                                              (when (second slice) `(:offset ,(second slice))))))))

525

*sql-environment*)))))

526

527

(defgeneric compute-bgp-sql (repository pattern)

528

529

(:method ((repository repository) (pattern list))

530

"Given a BGP. extract the property-variable relation, distinguished by class and join variable.

531

combine this with the property variable map from the api definition to yield join constraints and

532

the relation between sparql variables and sql columns.

533

return a 'table' description to make this information available to generate select expressions."

534

535

(let* ((statements (remove-if-not #'elementary-bgp-statement-form-p pattern))

536

(pattern-bindings (compute-pattern-bindings statements))

537

(filter (second (assoc 'spocq.a:|filter| pattern)))

538

(type (bgp-pattern-type statements))

539

(api (repository-resource-api repository type))

540

(view-name (cond (api (resource-api-view-name api))

541

                           (type (first (last (split-string  (puri:uri-path (puri:uri type)) "/"))))

542

((spocq:odbc-uri-p (repository-uri repository))

543

(spocq:odbc-uri-table (repository-uri repository)))

544

(t

545

"system")))

546

(view-identifier (sql-ident-table view-name))

547

;; there should not be any, but still...

548

(slice (rest (assoc 'spocq.a:|slice| pattern)))

549

;; generate a new env for the bgp - avaialbly dynamically for use in subexpressions

550

(*sql-environment* (make-sql-environment :as (gentemp (sql-ident-table-name view-identifier))))

551

;; get the predicate -> query parameter map

552

;(input-mapping (when api (resource-api-input-mapping api)))

553

;(output-mapping (when api (resource-api-output-mapping api)))

554

)

555

(loop for (predicate . variable) in pattern-bindings

556

for attribute = (when (variable-p variable)

557

(resource-api-output-attribute api predicate variable))

558

when attribute

559

do (setf (sql-variable-attribute variable *sql-environment*)

560

(sql-attribute attribute (sql-ident-table-name view-identifier))))

561

(loop for (predicate . variable) in pattern-bindings

562

for attribute = (when (variable-p variable)

563

(resource-api-input-attribute api predicate variable))

564

unless (or (null attribute) (sql-variable-attribute variable *sql-environment*))

565

do (setf (sql-variable-attribute variable *sql-environment*)

566

(sql-attribute attribute (sql-ident-table-name view-identifier))))

567

(let* ((constraints (loop for (predicate . variable) in pattern-bindings

568

                           for attribute = (resource-api-input-attribute api predicate variable)

569

when (and attribute

570

(or (not (variable-p variable))

571

                                         (let ((value (query-binding-value variable)))

572

                                           (and value (not (SPOCQ:UNBOUND-VARIABLE-P value))))))

573

collect (clsql:sql-operation '=

574

                                                        (sql-attribute attribute (sql-ident-table-name view-identifier))

575

                                                        (compute-sql-expression variable))))

576

(where (if (rest constraints)

577

                       (reduce #'(lambda (c1 c2) (clsql:sql-operation 'and c1 c2)) constraints)

578

(first constraints))))

579

;; (print where)

580

(when filter

581

(setf where (clsql:sql-operation :and where (compute-sql-expression filter))))

582

;; (print where)

583

(let ((sql (apply #'clsql:sql-operation 'select

584

(append (mapcar #'rest (sql-environment-map *sql-environment*))

585

                                 `(:from ,view-identifier ;; (sql-ident-qualified-table-name view-identifier) ;; (clsql:sql-expression :table view-identifier)

586

,@(when where `(:where ,where))

587

                                         ,@(when (first slice) `(:limit ,(first slice)))

588

                                         ,@(when (second slice) `(:offset ,(second slice))))))))

589

(values sql *sql-environment*))))))

590

591

(def-compute-sql-method spocq.a:|bindings| (repository values variables)

592

"Transform the bindings from a values clause into an in clause"

593

(declare (ignore repository))

594

(let ((constraints (loop for i from 0 for variable in variables

595

collect (list variable

596

(loop for values in values

597

collect (elt values i)))))

598

(*sql-environment* (make-sql-environment )))

599

(flet ((combine-in (e1 &optional e2)

600

(if e2

601

(clsql:sql-operation :and e1 e2)

602

e1))

603

(make-in (in) (destructuring-bind (variable values) in

604

                            (let ((attribute (sql-attribute (intern (symbol-name variable) :keyword))))

605

                              (setf (sql-variable-attribute variable *sql-environment*) attribute)

606

                              (clsql:sql-operation :in (clsql:sql-expression :attribute attribute)

607

values)))))

608

(declare (dynamic-extent #'combine-in))

609

(values (reduce #'combine-in constraints :key #'make-in)

610

*sql-environment*))))

611

612

(def-compute-sql-method spocq.a:|construct| (repository solution-field pattern)

613

"proceed with just the where clause"

614

(funcall (ecase *sql-translation-mode* (:debug #'write-log-warn) (:execute #'error)

615

(:translate #'list))

616

"Operator ~s not supported in SQL . ~s"

617

operator pattern)

618

(compute-sparql-sql repository solution-field))

619

620

(def-compute-sql-method spocq.a:|diff| (repository solution-field1 solution-field2 test-expression)

621

(declare (ignore test-expression))

622

(multiple-value-bind (sql1 e1) (compute-sparql-sql repository solution-field1)

623

(multiple-value-bind (sql2 e2) (compute-sparql-sql repository solution-field2)

624

(values (clsql:sql-operation :minus sql1 sql2)

625

(combine-sql-environments 'spocq.a:|diff| e1 e2)))))

626

627

(def-compute-sql-method spocq.a:|distinct| (repository solution-field &rest args)

628

(declare (ignore args))

629

(if (select-form-operator-p (first solution-field))

630

(compute-sparql-sql repository (append solution-field `(:distinct t)))

631

(multiple-value-bind (sql e) (compute-sparql-sql repository solution-field)

632

(setf (slot-value sql 'clsql-sys::distinct) t)

633

(values sql e))))

634

635

(def-compute-sql-method spocq.a:|extend| (repository solution-field variable value)

636

"Iff the constituent field yields a select, then augment its projection with the as expresion.

637

Otherwise, create an autonomous select and cross-join with the constituent"

638

(multiple-value-bind (sql *sql-environment*) (compute-sparql-sql repository solution-field)

639

(let* ((attribute (sql-attribute variable))

640

            (as-expression (make-instance 'clsql:sql-ident-expression :ident attribute :expression (compute-sql-expression value)))

641

(dual-table (make-instance 'clsql:sql-ident-table :name "dual")))

642

(typecase sql

643

(clsql:sql-query

644

(setf (sql-variable-attribute variable *sql-environment*) attribute)

645

(push as-expression (clsql:select-selections sql))

646

(values sql *sql-environment*))

647

(null

648

(values (clsql:sql-operation 'select as-expression :from (list dual-table))

649

(let ((env (make-sql-environment)))

650

(setf (sql-variable-attribute variable env) attribute)

651

env)))

652

(t

653

(setf (sql-variable-attribute variable *sql-environment*) attribute)

654

(values (clsql:sql-operation 'cross-join

655

                                       (clsql:sql-operation 'select as-expression)

656

sql)

657

*sql-environment*))))))

658

659

660

661

(def-compute-sql-method spocq.a:|filter| (repository solution-field test-expression)

662

(multiple-value-bind (sql *sql-environment*) (compute-sparql-sql repository solution-field)

663

(let ((where (clsql:select-where sql)))

664

;(print (list :sql sql :where where))

665

(cond (where

666

(setf (clsql:select-where sql)

667

(clsql:sql-operation :and where (compute-sql-expression test-expression)))

668

(values sql *sql-environment*))

669

(t

670

(values (make-instance 'CLSQL-SYS:SQL-query-modifier-exp

671

:components (list sql)

672

:modifier (compute-sql-expression test-expression))

673

*sql-environment*))))))

674

675

(def-compute-sql-method spocq.a:|join| (repository solution-field1 solution-field2 &key test)

676

(declare (ignore test))

677

(multiple-value-bind (sql1 e1) (compute-sparql-sql repository solution-field1)

678

(multiple-value-bind (sql2 e2) (compute-sparql-sql repository solution-field2)

679

(let* ((key-dimensions (join-key-dimensions (expression-dimensions solution-field1)

680

                                                   (expression-dimensions solution-field2)))

681

(constraints (loop for dimension in key-dimensions

682

                             for left-attribute = (sql-variable-attribute dimension e1)

683

                             for right-attribute = (sql-variable-attribute dimension e2)

684

;; only input and output variables appear,

685

                             ;; subject variable will be among the key dimensions, but nit the sql where constraints

686

when (and left-attribute right-attribute)

687

                             collect (clsql:sql-operation '= left-attribute right-attribute)))

688

(sql (clsql:sql-operation 'join sql1 sql2

689

(if (rest constraints)

690

                                            (reduce #'(lambda (c1 c2) (clsql:sql-operation 'and c1 c2)) constraints)

691

(first constraints)))))

692

(values sql

693

(combine-sql-environments 'spocq.a:|join| e1 e2))))))

694

695

(def-compute-sql-method spocq.a:|leftjoin| (repository solution-field1 solution-field2 &key test)

696

(assert (null test) ()

697

"leftjoin test clause not supported: ~s" test)

698

(multiple-value-bind (sql1 e1) (compute-sparql-sql repository solution-field1)

699

(multiple-value-bind (sql2 e2) (compute-sparql-sql repository solution-field2)

700

(let* ((key-dimensions (join-key-dimensions (expression-dimensions solution-field1)

701

                                                   (expression-dimensions solution-field2)))

702

(constraints (loop for dimension in key-dimensions

703

                             for left-attribute = (sql-variable-attribute dimension e1)

704

                             for right-attribute = (sql-variable-attribute dimension e2)

705

;; only input and output variables appear,

706

                             ;; subject variable will be among the key dimensions, but nit the sql where constraints

707

when (and left-attribute right-attribute)

708

                             collect (clsql:sql-operation '= left-attribute right-attribute)))

709

(sql (clsql:sql-operation :left-join sql1 sql2

710

(if (rest constraints)

711

                                            (reduce #'(lambda (c1 c2) (clsql:sql-operation 'and c1 c2)) constraints)

712

(first constraints)))))

713

(values sql

714

(combine-sql-environments 'spocq.a:|leftjoin| e1 e2))))))

715

716

717

(def-compute-sql-method spocq.a:|minus| (repository solution-field1 solution-field2)

718

(multiple-value-bind (sql1 e1) (compute-sparql-sql repository solution-field1)

719

(multiple-value-bind (sql2 e2) (compute-sparql-sql repository solution-field2)

720

(values (clsql:sql-operation :minus sql1 sql2)

721

(combine-sql-environments 'spocq.a:|minus| e1 e2)))))

722

723

724

(def-compute-sql-method spocq.a:|order| (repository solution-field order-expression-list)

725

(if (select-form-operator-p (first solution-field))

726

(compute-sparql-sql repository (append solution-field `(:order ,order-expression-list)))

727

(multiple-value-bind (sql *sql-environment*) (compute-sparql-sql repository solution-field)

728

(setf (slot-value sql 'clsql-sys::order-by)

729

(compute-sql-order order-expression-list))

730

(values sql *sql-environment*))))

731

732

(def-compute-sql-method spocq.a:|project| (repository solution-field variables &rest args)

733

(compute-sparql-sql repository `(spocq.a:|select| ,solution-field ,variables ,@args)))

734

735

(def-compute-sql-method spocq.a:|reduced| (repository solution-field &rest args)

736

(compute-sparql-sql repository `(spocq.a:|distinct| ,solution-field ,@args)))

737

738

739

;;; the issue with modifiers:

740

;;; they appear as additions to an outer lexical form while the respective variable bindings

741

;;; occur arbitrarily far away and nested arbitrarily deepl.

742

 ;;; as the variables are global within a select, they must be unique, so a variable -> attribute map is sufficient

743

;;; to represent this, each translation must yield two values:

744

;;; - the sql translation

745

;;; - the variable->attribute map apparent in that scope.

746

 ;;; they combine as required by sparql combinational scope, which means thatwhere a given variable appears more than once,

747

 ;;; each time in connection with a different predicate, when they combine, they effect a join and just one attribute need remain

748

749

750

 (def-compute-sql-method spocq.a:|select| (repository solution-field variables &rest args &key count end offset start distinct reduced order)

751

   "Genarate the base expression, incorporate modifies, reduce the enviroment to reflect the projection."

752

(declare (ignore count end offset start))

753

(destructuring-bind (&key start end &allow-other-keys) (apply #'canonicalize-algebra-arguments args)

754

(multiple-value-bind (sql e) (compute-sparql-sql repository solution-field)

755

(cond ((typep sql 'clsql:sql-query)

756

(when start

757

(setf (slot-value sql 'clsql-sys::offset) start

758

(slot-value sql 'clsql-sys::limit) (- end start)))

759

(when (or distinct reduced)

760

(setf (slot-value sql 'clsql-sys::distinct) t))

761

(when order

762

(setf (slot-value sql 'clsql-sys::order-by)

763

(compute-sql-order order))))

764

(t

765

(let* ((from (clsql:select-from sql))

766

(columns (clsql:select-selections sql)))

767

(setf sql (apply #'clsql:sql-operation 'select

768

(append columns

769

                                         `(:from ,(if (listp from) from (list from))

770

                                                 ,@(when sql `(:where ,sql))

771

                                                 ,@(when (or reduced distinct) `(:distinct ,(or reduced distinct)))

772

                                                 ,@(when end `(:limit ,(- end start)))

773

                                                 ,@(when start `(:offset ,start))

774

                                                 ,@(when order `(:order-by ,(compute-sql-order order))))))))))

775

(let* ((project-all? (and (symbolp variables) (string-equal variables "*")))

776

(alias (sql-environment-as e))

777

;; iff a projection is present, apply it to he environment

778

;; otherwise mapp all attributes to the aliad

779

              (e-as (copy-sql-environment e :map (loop for (var . attr) in (sql-environment-map e)

780

                                                   when (or project-all? (member var variables))

781

                                                   collect (cons var (sql-attribute (clsql:sql-name attr) alias))))))

782

(setf (clsql:sql-ident-table-alias (clsql:select-from sql)) alias)

783

(values sql e-as)))))

784

785

(def-compute-sql-method spocq.a:|service| (repository location solution-field &rest args)

786

"proceed with just the remote query clause"

787

(declare (ignore args))

788

(funcall (ecase *sql-translation-mode* (:debug #'write-log-warn) (:execute #'error)

789

(:translate #'list))

790

"Operator ~s not supported in SQL . ~s"

791

operator location)

792

(compute-sparql-sql repository solution-field))

793

794

(def-compute-sql-method spocq.a:|slice| (repository solution-field &rest args)

795

(if (select-form-operator-p (first solution-field))

796

(compute-sparql-sql repository (append solution-field args))

797

(multiple-value-bind (sql e) (compute-sparql-sql repository solution-field)

798

         (destructuring-bind (&key (start 0) (end 0) &allow-other-keys) (apply #'canonicalize-algebra-arguments args)

799

(setf (slot-value sql 'clsql-sys::offset) start

800

(slot-value sql 'clsql-sys::limit) (- end start))

801

(values sql e)))))

802

803

(def-compute-sql-method spocq.a:|table| (repository &rest args)

804

(declare (ignore repository args))

805

nil)

806

807

(def-compute-sql-method spocq.a:|union| (repository solution-field1 solution-field2)

808

(multiple-value-bind (sql1 e1) (compute-sparql-sql repository solution-field1)

809

(multiple-value-bind (sql2 e2) (compute-sparql-sql repository solution-field2)

810

(values (clsql:sql-operation :union sql1 sql2)

811

(combine-sql-environments 'spocq.a:|diff| e1 e2)))))

812

813

814

;;;

815

;;; various sparql encodings

816

817

818

 (defmethod send-response-message ((operation t) (message-body cons) (stream t) (content-type mime:application/sql))

819

"Given a MESSAGE, and a STREAM with application/sql CONTENT-TYPE, translate the expression to SQL."

820

(when *algebra-trace-output*

821

(setf stream (make-broadcast-stream *algebra-trace-output* stream)))

822

(let ((*sql-translation-mode* :translate))

823

(write-sparql-sql message-body :stream stream))

824

(fresh-line stream))

825

826

 (defmethod send-response-message (operation (message-body solution-generator) (stream stream) (content-type mime:application/sql))

827

"Given the (possibly completed) solution generator, delegate to the symbolic expression method"

828

(let ((*response-header-types* nil)) ;; the headers are alread encoded

829

(send-response-message operation (query-sse-expression *task*) stream content-type)))

830

831

#|

832

833

;;; documentation

834

835

(loop for symbol being each external-symbol in *algebra-package*

836

when (macro-function symbol)

837

collect (cons symbol (documentation symbol 'function)))

838

|#