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

KindCoveredAll%
expression0109 0.0
branch00nil
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
 ;;; Copyright (c) 2006 by the authors.
4
 ;;;
5
 ;;; See LICENCE for details.
6
 
7
 (in-package :cl-perec)
8
 
9
 ;;;;;;;;;;;;;;;;;
10
 ;; Query frontend
11
 
12
 (defmacro select (&whole select-form (&rest variables) &body body &environment env)
13
   "Selects object from the model.
14
 
15
   Syntax:
16
 
17
      select [<options>] (<var-spec>*) <assert-clause>* <collect-clause> [<order-by-clause>]
18
 
19
      <options>:         (&key result-type flatp uniquep)
20
      <var-spec>:        <symbol> | (<symbol> <type-expr>)
21
      <assert-clause>:   (assert <bool-expr>)
22
      <collect-clause>:  (collect <expr>*)
23
      <order-by-clause>: (order-by <order-spec>*)
24
      <order-spec>:      :asc|:desc <expr>
25
 
26
   Semantics:
27
 
28
      The symbols of the form are bound to all objects in the database sequentially.
29
      Then the asserts are evaluated. If all asserts are satisfied then the expressions
30
      of the collect clause are added to the result. Finally the result is sorted according
31
      to the order-by-clause.
32
 
33
      Options may modify how the result is collected:
34
 
35
      result-type: (member 'list 'scroll)
36
         If the value is 'scroll then the result of the query returned as an instance
37
         of the 'scroll class. If the value is 'list the the result is a list.
38
         Default is 'list.
39
 
40
      flatp: generalized-boolean
41
         If true and the result-type is 'list then result is a flattened list, i.e. the 
42
         lists returned by the collect clause are appended rather than added to the result.
43
         Default is true for one element collect clauses, false otherwise.
44
 
45
      uniquep: generalized-boolean
46
         If true then the value of the collect clause will not be added to the result,
47
         when it is equal to a previously seen value.
48
 
49
      prefetchp: generalized-boolean
50
         If true then the values of slots of the returned objects are cached in the object.
51
         Default is true.
52
 
53
   Example:
54
 
55
      (let ((yesterday (day-before-today)))
56
        (select ((topic topic) message) 
57
          (assert (typep message 'message))
58
          (assert (eq (topic-of message) topic))
59
          (assert (after (date-of message) yesterday))
60
          (collect (name-of topic) message)))"
61
   (declare (ignore variables body))
62
   (let* ((lexical-variables (remove-duplicates (arnesi::lexical-variables env))))
63
     `(execute-query
64
       (make-query ',select-form ',lexical-variables)
65
       ,@lexical-variables)))
66
 
67
 (defmacro simple-select (options variable &body body)
68
   (bind ((variable-specification
69
           (typecase variable
70
             (null '-object-)
71
             (symbol `(-object- ,variable))
72
             (t variable)))
73
          (variable-name (first (ensure-list variable-specification))))
74
     `(select ,options (,variable-specification)
75
       ,@(append
76
          (mapcar #L`(assert ,!1) body)
77
          `((collect ,variable-name))))))
78
 
79
 (defmacro select-first-matching (&optional variable &body body)
80
   `(let ((scroll (simple-select (:result-type scroll) ,variable ,@body)))
81
     (when (> (element-count scroll) 0)
82
       (setf (page-size scroll) 1)
83
       (first-page! scroll)
84
       (first (aref (elements scroll) 0)))))
85
 
86
 (defmacro select-last-matching (&optional variable &body body)
87
   `(let ((scroll (simple-select (:result-type scroll) ,variable ,@body)))
88
     (when (> (element-count scroll) 0)
89
       (setf (page-size scroll) 1)
90
       (last-page! scroll)
91
       (first (aref (element scroll) 0)))))
92
 
93
 (defun select-similar-assert-for (type rest)
94
   (bind ((class (find-class type)))
95
     (iter (for (initarg value) on rest by 'cddr)
96
           (collect `(equal (,(first
97
                               (some #'slot-definition-readers
98
                                     (direct-slots-of
99
                                      (find initarg (class-slots class)
100
                                            :key #L(first (slot-definition-initargs !1))))))
101
                             -object-)
102
                      ,value)))))
103
 
104
 (defmacro select-similar-instance (type &rest rest &key &allow-other-keys)
105
   `(select-instance (-object- ,type)
106
     ,@(select-similar-assert-for type rest)))
107
 
108
 (defmacro select-similar-instances (type &rest rest &key &allow-other-keys)
109
   `(select-instances (-object- ,type)
110
     ,@(select-similar-assert-for type rest)))
111
 
112
 (defmacro select-instance (&optional variable &body body)
113
   `(let ((scroll (simple-select (:result-type scroll) ,variable ,@body)))
114
     (setf (page-size scroll) 1)
115
     (case (element-count scroll)
116
       (0 nil)
117
       (1 (first-page! scroll) (first (aref (elements scroll) 0)))
118
       (otherwise (error "Query did not return unique result.")))))
119
 
120
 (defmacro select-instances (&optional variable &body body)
121
   "Select objects using one variable and collect the values of that variable based upon a set of asserts."
122
   `(simple-select (:result-type list) ,variable ,@body))
123
 
124
 ;;;;;;;;;;;;;;;;;;;;;;;
125
 ;;; Execute and compile
126
 
127
 (defgeneric execute-query (query &rest lexical-variable-values)
128
   (:documentation "Executes the query with the given variable values, compiles the query when needed."))
129
 
130
 (defgeneric compile-query (query)
131
   (:documentation "Compiles the query to lisp code that executes the query."))
132
 
133
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
134
 ;; Query builder interface
135
 
136
 (defgeneric make-query (select-form &optional lexical-variables)
137
   (:documentation
138
    "Creates a query object from the SELECT-FORM.
139
 When the SELECT-FORM is NIL, an empty query created which can be modified by
140
 ADD-LEXICAL-VARIABLE, ADD-QUERY-VARIABLE, ADD-ASSERT and ADD-COLLECT"))
141
 
142
 (defgeneric add-lexical-variable (query variable)
143
   (:documentation
144
    "Add a lexical variable named VARIABLE to the QUERY.
145
 Lexical variables can be referenced in the asserts and collects of the query and their
146
 values are passed to EXECUTE-QUERY in the order they are added to the QUERY."))
147
 
148
 (defgeneric add-query-variable (query variable)
149
   (:documentation
150
    "Add a query variable named VARIABLE to the QUERY.
151
 Query variables can be referenced in the asserts and collects of the QUERY."))
152
 
153
 (defgeneric add-assert (query condition)
154
   (:documentation
155
    "Add an assert for the CONDITION form to the QUERY."))
156
 
157
 (defgeneric add-collect (query expression)
158
   (:documentation
159
    "Add a collect for the EXPRESSION form to the QUERY."))
160
 
161
 (defgeneric add-order-by (query expression &optional direction)
162
   (:documentation
163
    "Add an order-by clause specified by EXPRESSION and DIRECTION to the QUERY."))
164
 
165
 (defgeneric set-order-by (query expression &optional direction)
166
   (:documentation
167
    "Set an order-by clause specified by EXPRESSION and DIRECTION to the QUERY."))