Added cross-reference-related!

untyped · Oct 20, 2010 · 087f0d2 · 087f0d2
1 parent 4f7726c
commit 087f0d2
Show file tree

Hide file tree

Showing 3 changed files with 140 additions and 48 deletions.
diff --git a/snooze-api.ss b/snooze-api.ss
@@ -69,6 +69,10 @@
 (define (load-related! #:snooze [snooze (current-snooze)] structs attr)
   (send snooze load-related! structs attr))
 
+; (listof snooze-struct) attribute -> (listof snooze-struct)
+(define (cross-reference-related! #:snooze [snooze (current-snooze)] structs attr other-structs)
+  (send snooze cross-reference-related! structs attr other-structs))
+
 ; (-> ans) any ... -> ans
 (define (call-with-transaction #:snooze [snooze (current-snooze)] #:metadata [metadata null] thunk)
   (send snooze call-with-transaction #:metadata metadata thunk))
@@ -130,27 +134,32 @@
          with-transaction)
 
 (provide/contract
- [call-with-connection  (->* (procedure?) (#:snooze (is-a?/c snooze<%>)) any)]
- [connect               (->* () (#:snooze (is-a?/c snooze<%>)) void?)]
- [disconnect            (->* () (#:snooze (is-a?/c snooze<%>)) void?)]
- [current-connection    (->* () (#:snooze (is-a?/c snooze<%>)) connection?)]
- [create-table          (->* (entity?) (#:snooze (is-a?/c snooze<%>)) void?)]
- [drop-table            (->* ((or/c entity? symbol?)) (#:snooze (is-a?/c snooze<%>)) void?)]
- [save!                 (->* (snooze-struct?)
-                             (#:snooze (is-a?/c snooze<%>))
-                             (and/c snooze-struct? snooze-struct-has-revision?))]
- [delete!               (->* (snooze-struct?)
-                             (#:snooze (is-a?/c snooze<%>))
-                             (and/c snooze-struct? (not/c snooze-struct-has-revision?)))]
- [find-one              (->* (query?) (#:snooze (is-a?/c snooze<%>)) any)]
- [find-all              (->* (query?) (#:snooze (is-a?/c snooze<%>)) (or/c null? pair?))]
- [g:find                (->* (query?) (#:snooze (is-a?/c snooze<%>)) procedure?)]
- [find-by-id            (->* (entity? natural-number/c) (#:snooze (is-a?/c snooze<%>)) (or/c snooze-struct? #f))]
- [find-by-guid          (->* (database-guid?) (#:snooze (is-a?/c snooze<%>)) (or/c snooze-struct? #f))]
- [find-by-guids         (->* ((listof database-guid?)) (#:snooze (is-a?/c snooze<%>)) (listof snooze-struct?))]
- [load-related!         (->* ((listof snooze-struct?) attribute?) (#:snooze (is-a?/c snooze<%>)) (listof snooze-struct?))]
- [call-with-transaction (->* (procedure?) (#:snooze (is-a?/c snooze<%>) #:metadata list?) any)]
- [query->string         (->* (query?) (#:snooze (is-a?/c snooze<%>)) string?)]
- [debug-sql             (->* (query?) (#:snooze (is-a?/c snooze<%>) #:output-port output-port? #:format string?) query?)]
- [table-names           (->* () (#:snooze (is-a?/c snooze<%>)) (listof symbol?))]
- [table-exists?         (->* ((or/c entity? symbol?)) (#:snooze (is-a?/c snooze<%>)) boolean?)])
+ [call-with-connection     (->* (procedure?) (#:snooze (is-a?/c snooze<%>)) any)]
+ [connect                  (->* () (#:snooze (is-a?/c snooze<%>)) void?)]
+ [disconnect               (->* () (#:snooze (is-a?/c snooze<%>)) void?)]
+ [current-connection       (->* () (#:snooze (is-a?/c snooze<%>)) connection?)]
+ [create-table             (->* (entity?) (#:snooze (is-a?/c snooze<%>)) void?)]
+ [drop-table               (->* ((or/c entity? symbol?)) (#:snooze (is-a?/c snooze<%>)) void?)]
+ [save!                    (->* (snooze-struct?)
+                                (#:snooze (is-a?/c snooze<%>))
+                                (and/c snooze-struct? snooze-struct-has-revision?))]
+ [delete!                  (->* (snooze-struct?)
+                                (#:snooze (is-a?/c snooze<%>))
+                                (and/c snooze-struct? (not/c snooze-struct-has-revision?)))]
+ [find-one                 (->* (query?) (#:snooze (is-a?/c snooze<%>)) any)]
+ [find-all                 (->* (query?) (#:snooze (is-a?/c snooze<%>)) (or/c null? pair?))]
+ [g:find                   (->* (query?) (#:snooze (is-a?/c snooze<%>)) procedure?)]
+ [find-by-id               (->* (entity? natural-number/c) (#:snooze (is-a?/c snooze<%>)) (or/c snooze-struct? #f))]
+ [find-by-guid             (->* (database-guid?) (#:snooze (is-a?/c snooze<%>)) (or/c snooze-struct? #f))]
+ [find-by-guids            (->* ((listof database-guid?)) (#:snooze (is-a?/c snooze<%>)) (listof snooze-struct?))]
+ [load-related!            (->* ((listof snooze-struct?) attribute?)
+                                (#:snooze (is-a?/c snooze<%>))
+                                (listof snooze-struct?))]
+ [cross-reference-related! (->* ((listof snooze-struct?) attribute? (listof snooze-struct?))
+                                (#:snooze (is-a?/c snooze<%>))
+                                (listof snooze-struct?))]
+ [call-with-transaction    (->* (procedure?) (#:snooze (is-a?/c snooze<%>) #:metadata list?) any)]
+ [query->string            (->* (query?) (#:snooze (is-a?/c snooze<%>)) string?)]
+ [debug-sql                (->* (query?) (#:snooze (is-a?/c snooze<%>) #:output-port output-port? #:format string?) query?)]
+ [table-names              (->* () (#:snooze (is-a?/c snooze<%>)) (listof symbol?))]
+ [table-exists?            (->* ((or/c entity? symbol?)) (#:snooze (is-a?/c snooze<%>)) boolean?)])
diff --git a/snooze-class.ss b/snooze-class.ss
@@ -261,6 +261,47 @@
           ; Return the original argument:
           structs)))
 
+    ; Takes:
+    ;   - a list of structs of the same entity;
+    ;   - a foreign key attribute from that entity;
+    ;   - a list of structs of the foreign key type.
+    ;
+    ; Iterates through the structs finding any unloaded database-guids in the foreign key attribute.
+    ; Loads the related structs and cross references the foreign keys.
+    ; Returns the original (listof struct) argument, mutated with the cross references in place.
+    ;
+    ; (listof snooze-struct) attribute -> (listof snooze-struct)
+    (define/public (cross-reference-related! structs attr other-structs)
+      (let ([entity       (attribute-entity attr)]
+            [accessor     (attribute-private-accessor attr)]
+            [mutator      (attribute-private-mutator  attr)]
+            [lookup-table (make-hash)])
+
+        ; database-guid -> (U database-guid snooze-struct)
+        (define (lookup guid)
+          (hash-ref lookup-table guid guid))
+
+        ; Quick type check:
+        (unless (and (guid-type? (attribute-type attr))
+                     (memq attr (entity-data-attributes entity)))
+          (raise-type-error 'find-related! "foreign-key-attribute" attr))
+
+        ; Populate the lookup table:
+        (for ([struct (in-list other-structs)])
+          (hash-set! lookup-table (snooze-struct-guid struct) struct))
+
+        ; Work out which foreign keys need loading, and which structs need mutating:
+        (for ([struct (in-list structs)])
+          (let ([val (accessor struct)])
+            (when (database-guid? val)
+              ; Lookup returns:
+              ;   - the new struct if it's in lookup-table;
+              ;   - the original guid if the struct isn't in the lookup-table;
+              (mutator struct (lookup val)))))
+
+        ; Return the original argument:
+        structs))
+
     ; thunk [#:metadata list] -> any
     ;
     ; If the database allows it, a transaction is started and the thunk argument

diff --git a/snooze-find-test.ss b/snooze-find-test.ss
@@ -312,32 +312,74 @@
 
     (test-case "load-related!"
       (recreate-test-tables)
-      (match-let* ([per1 (save! (make-person/defaults #:name "Christian"))]
-                   [per2 (save! (make-person/defaults #:name "Dave"))]
-                   [per3 (save! (make-person/defaults #:name "David"))]
-                   [per4 (save! (make-person/defaults #:name "Matt"))]
-                   [per5 (make-person/defaults #:name "Noel")]
-                   [pet1 ((entity-private-constructor pet)
-                          (entity-make-temporary-guid pet)
-                          #f
-                          (snooze-struct-guid per1)
-                          "Christian's budgie")]
-                   [pet2 ((entity-private-constructor pet)
-                          (entity-make-temporary-guid pet)
-                          #f
-                          (snooze-struct-guid per2)
-                          "Dave's dog")]
-                   [pet3 (make-pet/defaults #:owner per3                      #:name "David's kitten")]
-                   [pet4 (make-pet/defaults #:owner #f                        #:name "Stray goat")]
-                   [pet5 (make-pet/defaults #:owner per5                      #:name "Noel's cat")]
-                   [pets (list pet1 pet1 pet2 pet3 pet3 pet4 pet5 pet5 pet1)])
+      (match-let* ([per1       (save! (make-person/defaults #:name "Christian"))]
+                   [per2       (save! (make-person/defaults #:name "Dave"))]
+                   [per3       (save! (make-person/defaults #:name "David"))]
+                   [per4       (save! (make-person/defaults #:name "Matt"))]
+                   [per5       (make-person/defaults #:name "Noel")]
+                   [pet1       ((entity-private-constructor pet)
+                                (entity-make-temporary-guid pet)
+                                #f
+                                (snooze-struct-guid per1)
+                                "Christian's budgie")]
+                   [pet2       ((entity-private-constructor pet)
+                                (entity-make-temporary-guid pet)
+                                #f
+                                (snooze-struct-guid per2)
+                                "Dave's dog")]
+                   [pet3       (make-pet/defaults #:owner per3                      #:name "David's kitten")]
+                   [pet4       (make-pet/defaults #:owner #f                        #:name "Stray goat")]
+                   [pet5       (make-pet/defaults #:owner per5                      #:name "Noel's cat")]
+                   [pets       (list pet1 pet1 pet2 pet3 pet3 pet4 pet5 pet5 pet1)]
+                   [pet-owner* (lambda (struct)
+                                 (vector-ref (struct->vector struct) 3))])
+        (check-equal? (pet-owner* pet1) (snooze-struct-guid per1))
+        (check-equal? (pet-owner* pet2) (snooze-struct-guid per2))
+        (check-equal? (pet-owner* pet3) per3)
+        (check-equal? (pet-owner* pet4) #f)
+        (check-equal? (pet-owner* pet5) per5)
         (check-eq? (load-related! pets (attr pet owner)) pets)
-        (check-equal? (pet-owner pet1) per1)
-        (check-equal? (pet-owner pet2) per2)
-        (check-equal? (pet-owner pet3) per3)
-        (check-equal? (pet-owner pet4) #f)
-        (check-equal? (pet-owner pet5) per5))))
+        (check-equal? (pet-owner* pet1) per1)
+        (check-equal? (pet-owner* pet2) per2)
+        (check-equal? (pet-owner* pet3) per3)
+        (check-equal? (pet-owner* pet4) #f)
+        (check-equal? (pet-owner* pet5) per5))))
 
+    (test-case "cross-reference-related!"
+      (recreate-test-tables)
+      (match-let* ([per1       (save! (make-person/defaults #:name "Christian"))]
+                   [per2       (save! (make-person/defaults #:name "Dave"))]
+                   [per3       (save! (make-person/defaults #:name "David"))]
+                   [per4       (save! (make-person/defaults #:name "Matt"))]
+                   [per5       (make-person/defaults #:name "Noel")]
+                   [pet1       ((entity-private-constructor pet)
+                                (entity-make-temporary-guid pet)
+                                #f
+                                (snooze-struct-guid per1)
+                                "Christian's budgie")]
+                   [pet2       ((entity-private-constructor pet)
+                                (entity-make-temporary-guid pet)
+                                #f
+                                (snooze-struct-guid per2)
+                                "Dave's dog")]
+                   [pet3       (make-pet/defaults #:owner per3                      #:name "David's kitten")]
+                   [pet4       (make-pet/defaults #:owner #f                        #:name "Stray goat")]
+                   [pet5       (make-pet/defaults #:owner per5                      #:name "Noel's cat")]
+                   [pets       (list pet1 pet1 pet2 pet3 pet3 pet4 pet5 pet5 pet1)]
+                   [pet-owner* (lambda (struct)
+                                 (vector-ref (struct->vector struct) 3))])
+        (check-equal? (pet-owner* pet1) (snooze-struct-guid per1))
+        (check-equal? (pet-owner* pet2) (snooze-struct-guid per2))
+        (check-equal? (pet-owner* pet3) per3)
+        (check-equal? (pet-owner* pet4) #f)
+        (check-equal? (pet-owner* pet5) per5)
+        (check-eq? (cross-reference-related! pets (attr pet owner) (list per1 per3)) pets)
+        (check-equal? (pet-owner* pet1) per1)
+        (check-equal? (pet-owner* pet2) (snooze-struct-guid per2))
+        (check-equal? (pet-owner* pet3) per3)
+        (check-equal? (pet-owner* pet4) #f)
+        (check-equal? (pet-owner* pet5) per5)))
+
   (test-suite "serializing / deserializing data"
 
     (test-case "backslashes and quotes in strings"