Skip to content

Commit

Permalink
SQL now serializable:
Browse files Browse the repository at this point in the history 
  - entity-aliases use entity-names rather than entities,
    and look up entities via current-model at extract/render time;
  - attribute-aliases use attribute-names rather than attributes (see above);
  - extract-info is an (opt-listof (U entity-name #f)) rather than (opt-listof (U entity type)).
  • Loading branch information
Dave Gurnell committed Mar 13, 2010
1 parent 877bc8b commit cc4ed83
Show file tree
Hide file tree
Showing 8 changed files with 118 additions and 115 deletions.
21 changes: 8 additions & 13 deletions common/cross-reference-test.ss
View file
Expand Up @@ -68,15 +68,10 @@
(test-suite "cross-reference.ss"

(test-case "count-entities"
(check-equal? (count-entities person) 1)
(check-equal? (count-entities type:integer) 0)
(check-equal? (count-entities (list person person)) 2)
(check-equal? (count-entities (list (attribute-type (attr person guid))
person
(attribute-type (attr pet owner))
pet
course))
3))
(check-equal? (count-entities 'person) 1)
(check-equal? (count-entities #f) 0)
(check-equal? (count-entities '(person person)) 2)
(check-equal? (count-entities '(#f person #f pet course)) 3))

(test-equal? "column->struct-index"
(for/list ([i (in-range 0 10)])
Expand Down Expand Up @@ -129,7 +124,7 @@
(list pet3 per3)
(list pet4 per4))]
[xref* (make-cross-referencer (append (entity-columns pet) (entity-columns person))
(list pet person)
'(pet person)
(build-hash (sql-list pet.owner person.guid)))]
[xref (cut xref* <> (transaction-frame-push #f))]
[do-row (g:map xref (g:list input))])
Expand Down Expand Up @@ -170,7 +165,7 @@
[xref* (make-cross-referencer (append (entity-columns pet)
(entity-columns person)
(entity-columns vehicle))
(list pet person vehicle)
'(pet person vehicle)
(build-hash (sql-list pet.owner person.guid
vehicle.owner person.guid
vehicle.occupant pet.guid)))]
Expand Down Expand Up @@ -207,7 +202,7 @@
(list pet2 per2 veh2))]
[xref* (make-cross-referencer (append (entity-columns pet)
(entity-columns vehicle))
(list pet vehicle)
'(pet vehicle)
(build-hash (sql-list pet.owner person.guid)))]
[xref (cut xref* <> (transaction-frame-push #f))]
[do-row (g:map xref (g:list input))])
Expand All @@ -231,7 +226,7 @@
(list expr2)
(entity-columns person)
(list expr3))
(list type:integer pet type:integer person type:integer)
'(#f pet #f person #f)
(build-hash (sql-list pet.owner person.guid)))]
[xref (cut xref* <> (transaction-frame-push #f))]
[do-row (g:map xref (g:list input))])
Expand Down
58 changes: 29 additions & 29 deletions common/cross-reference.ss
View file
Expand Up @@ -45,28 +45,28 @@

; query -> (query-result -> query-result)
(define/public (make-query-cross-referencer query)
(let ([cols (query-what query)]
[entities+types (query-extract-info query)]
[xrefs (source->foreign-keys (query-from query))])
(make-cross-referencer cols entities+types xrefs)))
(make-cross-referencer
(query-what query)
(query-extract-info query)
(source->foreign-keys (query-from query))))

; (listof column)
; (U entity type (listof (U entity type)))
; (U symbol #f (listof (U symbol #f)))
; (hashof column column)
; ->
; (query-result -> query-result)
(define/public (make-cross-referencer cols entities+types xrefs)
(define/public (make-cross-referencer cols info xrefs)
; Pass throughs: there's NEVER any cross-referencing to do if:
; - we're not selecting more than one entity;
; - there are no cross references in the FROM clause.
(if (or (<= (count-entities entities+types) 1)
(if (or (<= (count-entities info) 1)
(zero? (dict-count xrefs)))
; Create a dummy cross-referencer that does nothing:
(lambda (item frame) item)
; Create a real cross-referencer:
(let*-values ([(sizes) (entities->sizes entities+types)]
(let*-values ([(sizes) (entities->sizes info)]
; Mask out any primary and foreign keys that aren't part of an extracted snooze-struct:
[(cols) (entities->mask entities+types cols)]
[(cols) (entities->mask info cols)]
[(mutators local-indices remote-indices)
(for/fold ([mutators null] [local-indices null] [remote-indices null])
([fk (in-list cols)])
Expand All @@ -90,40 +90,40 @@

; Helpers ----------------------------------------

; (listof (U entity type)) [natural] -> natural
(define (count-entities entities+types [accum 0])
(cond [(pair? entities+types)
(if (entity? (car entities+types))
(count-entities (cdr entities+types) (add1 accum))
(count-entities (cdr entities+types) accum))]
[(null? entities+types) accum]
[(entity? entities+types) 1]
; (listof (U symbol #f)) [natural] -> natural
(define (count-entities info [accum 0])
(cond [(pair? info)
(if (car info)
(count-entities (cdr info) (add1 accum))
(count-entities (cdr info) accum))]
[(null? info) accum]
[info 1]
[else 0]))

; (listof (U entity type)) -> (listof (U column #f))
; (listof (U symbol #f)) -> (listof (U column #f))
;
; Returns a mask of booleans over the query's columns:
; any columns not involved in entities are masked out with #f.
;
; We need this to avoid cross-referencing columns that aren't inside entities.
; See the test case "make-cross-referencer: mixture of entities and single columns" for more information.
(define (entities->mask entities+types cols)
(define (entities->mask info cols)
(map (cut and <> <>)
(append-map (lambda (entity+type)
(if (entity? entity+type)
(make-list (length (entity-attributes entity+type)) #t)
(append-map (lambda (info)
(if info
(make-list (length (entity-attributes (model-entity (current-model) info))) #t)
(list #f)))
entities+types)
info)
cols))

; (listof (U entity type)) -> (listof integer)
; (listof (U symbol #f)) -> (listof integer)
; Works out the size of each item in a result row.
(define (entities->sizes entities+types)
(map (lambda (entity+type)
(if (entity? entity+type)
(length (entity-attributes entity+type))
(define (entities->sizes info)
(map (lambda (info)
(if info
(length (entity-attributes (model-entity (current-model) info)))
1))
entities+types))
info))

; column (listof column) (listof integer) -> (U natural #f)
; Works out which struct any given column is inside.
Expand Down
12 changes: 6 additions & 6 deletions common/extract.ss
View file
Expand Up @@ -23,14 +23,14 @@

; query -> (U single-item-extractor multi-item-extractor)
(define/public (make-query-extractor query)
(let ([extract-info (query-extract-info query)])
(if (or (pair? extract-info) (null? extract-info))
(let ([info (query-extract-info query)])
(if (or (pair? info) (null? info))
(make-multiple-item-extractor
(map (lambda (item)
(and (entity? item) item))
extract-info))
(map (lambda (info)
(and info (model-entity (current-model) info)))
info))
(make-single-item-extractor
(and (entity? extract-info) extract-info)))))
(and info (model-entity (current-model) info))))))

; (U entity #f) -> single-item-extractor
; where single-item-extractor
Expand Down
4 changes: 2 additions & 2 deletions common/sql-query.ss
View file
Expand Up @@ -155,8 +155,8 @@
; entity-alias output-port -> void
(define (display-from/entity alias out)
(match alias
[(struct entity-alias (id entity))
(display (escape-sql-name (entity-table-name entity)) out)
[(struct entity-alias (id entity-name))
(display (escape-sql-name (entity-table-name (model-entity (current-model) entity-name))) out)
(display " AS " out)
(display (escape-sql-name id) out)]))

Expand Down
23 changes: 9 additions & 14 deletions sql/sql-lang-test.ss
View file
Expand Up @@ -20,7 +20,7 @@
(test-case "alias"
(begin-with-definitions

(define p (make-entity-alias 'p person))
(define p (make-entity-alias 'p 'person))
(define q (make-query null #f p #f null null #f #f #f null null null))

(check-equal? (sql:alias 'p person) p "entity")
Expand Down Expand Up @@ -163,11 +163,11 @@
(define select1 (sql:select #:from p1))

(check-equal? (query-extract-info (sql:select #:from p1))
person
'person
"entity")

(check-equal? (query-extract-info (sql:select #:from (sql:outer p1 p2)))
(list person pet)
'(person pet)
"join")))

(test-case "select : queries in #:from get quoted"
Expand Down Expand Up @@ -333,20 +333,19 @@
(define p1-average-id (sql:average (sql p1.revision)))

(check-equal? (query-extract-info (sql:select #:what (sql p1.revision) #:from p1))
(make-integer-type #f 0 #f)
#f
"single attribute")

(check-equal? (query-extract-info (sql:select #:what (list (sql p1.revision) (sql p1.name)) #:from p1))
(list (make-integer-type #f 0 #f)
(make-string-type #t #f))
'(#f #f)
"list of attributes")

(check-equal? (query-extract-info (sql:select #:from p1))
person
'person
"single entity")

(check-equal? (query-extract-info (sql:select #:from (sql:outer p1 p2)))
(list person person)
'(person person)
"multiple entities")

(check-equal? (query-extract-info (sql:select #:what (list p1-count-id
Expand All @@ -355,19 +354,15 @@
p1-min-revision
p1-average-id)
#:from p1))
(list (make-integer-type #t #f #f)
(make-integer-type #t #f #f)
(make-integer-type #f 0 #f)
(make-integer-type #f 0 #f)
(make-real-type #t #f #f))
'(#f #f #f #f #f)
"aggregates")

(check-equal? (query-extract-info (sql:select #:what (list (sql:alias 'column1 (sql:+ (sql p1.revision) (sql p1.revision)))
(sql:alias 'column2 (sql:+ p1-count-id 1.5))
(sql:alias 'column3 (sql:string-append (sql p1.name) " rocks!"))
(sql:alias 'column4 (sql:> (sql p1.revision) 123)))
#:from p1))
(list type:integer type:real type:string type:boolean)
'(#f #f #f #f)
"expressions")))))

; Provide statements -----------------------------
Expand Down
18 changes: 9 additions & 9 deletions sql/sql-lang.ss
View file
Expand Up @@ -22,24 +22,24 @@
(define sql:alias
(match-lambda*
[(list (? symbol? id) (? entity? item))
(make-entity-alias id item)]
(make-entity-alias id (entity-name item))]
[(list (? symbol? id) (? query? item))
(make-query-alias id item)]
[(list (? symbol? id) (? non-alias-expression? item))
(make-expression-alias id item)]
[(list (and alias (struct entity-alias (name entity))) (? attribute? attr))
(define entity (source-alias-value alias))
(if (eq? (attribute-entity attr) entity)
(make-attribute-alias alias attr)
(raise-exn exn:fail:contract
(format "Entity does not contain that attribute: ~a ~a" entity attr)))]
[other (raise-exn exn:fail:contract (format "Bad arguments to sql:alias: ~s" other))]))
[(list (? entity-alias? alias) (? attribute? attr))
(let ([entity (entity-alias-entity alias)])
(if (eq? (attribute-entity attr) entity)
(make-attribute-alias alias attr)
(raise-exn exn:fail:contract
(format "attribute not found: ~a ~a" entity attr))))]
[other (raise-exn exn:fail:contract (format "bad arguments to sql:alias: ~s" other))]))

; entity-alias (U symbol attribute) -> attribute-alias
;
; Provides backwards compatibility with the q:attr form in a previous Snooze query language.
(define (sql:attr alias attr+name)
(make-attribute-alias alias (entity-attribute (source-alias-value alias) attr+name)))
(make-attribute-alias alias (entity-attribute (entity-alias-entity alias) attr+name)))

; any -> boolean
(define (non-alias-expression? item)
Expand Down

0 comments on commit cc4ed83

Please sign in to comment.