1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
#lang racket
(provide nutrient
nutrient?
nutrient-id
nutrient-canonical-name
nutrient-french-name
nutrient-formula
nutrient-value-hash/c
(contract-out [create-nutrient! (-> string? string? string? nutrient?)]
[get-nutrients (-> (listof nutrient?))]
[get-nutrient
(->* ()
(#:id (or/c #f exact-nonnegative-integer?)
#:name (or/c #f string?)
#:formula (or/c #f string?))
(or/c nutrient? #f))]
[update-nutrient!
(->* (nutrient?)
(#:name (or/c #f string?) #:formula (or/c #f string?))
(or/c nutrient? #f))]
[delete-nutrient! (-> nutrient? void?)]
[residuals->nutrient-value-hash
(-> (listof residual-vector/c) nutrient-value-hash/c)]))
(require racket/contract
db
sql
"../db/conn.rkt")
(struct nutrient (id canonical-name french-name formula)
#:transparent
#:property prop:custom-write
(λ (v out _) (fprintf out "#<~a ~a>" (nutrient-id v) (nutrient-canonical-name v))))
(define nutrient-value-hash/c (hash/c nutrient? (and/c real? (>=/c 0)) #:immutable #t))
;; vector/c id, canonical name, french name, nutrient formula, value (ppm)
(define residual-vector/c (vector/c exact-nonnegative-integer? string? string? string? real?))
(define (residuals->nutrient-value-hash residuals)
(for/hash ([r (in-list residuals)])
(match-define (vector n-id n-canonical-name n-french-name n-formula value-ppm) r)
(values (nutrient n-id n-canonical-name n-french-name n-formula) value-ppm)))
;; CREATE
(define (create-nutrient! canonical-name french-name formula)
(or (get-nutrient #:name canonical-name #:formula formula)
(with-tx
(query-exec (current-conn)
(insert #:into nutrients
#:set [canonical_name ,canonical-name]
[french_name ,french-name]
[formula ,formula]))
(get-nutrient #:name canonical-name))))
;; READ
(define (row->nutrient row)
(match-define (vector id canonical-name french-name formula) row)
(nutrient id canonical-name french-name formula))
(define (get-nutrients)
(define rows
(query-rows (current-conn)
(select id canonical_name french_name formula #:from nutrients #:order-by id #:asc)))
(map row->nutrient rows))
(define (get-nutrient #:id [id #f] #:name [canonical-name #f] #:formula [formula #f])
(define where
(cond
[(and id canonical-name formula)
(scalar-expr-qq (and (= id ,id) (= canonical_name ,canonical-name)))]
[id (scalar-expr-qq (= id ,id))]
[(and canonical-name formula)
(scalar-expr-qq (and (= canonical_name ,canonical-name) (= formula ,formula)))]
[canonical-name (scalar-expr-qq (= canonical_name ,canonical-name))]
[formula (scalar-expr-qq (= formula ,formula))]))
(match (query-maybe-row (current-conn)
(select id
canonical_name
french_name
formula
#:from nutrients
#:where (ScalarExpr:AST ,where)
#:order-by id
#:asc
#:limit 1))
[(vector id canonical-name french-name formula) (nutrient id canonical-name french-name formula)]
[#f #f]))
;; UPDATE
(define (update-nutrient! nutrient #:name [name #f] #:formula [formula #f])
(define id (nutrient-id nutrient))
(cond
[(and name formula)
(query-exec
(current-conn)
(update nutrients #:set [canonical_name ,name] [formula ,formula] #:where (= id ,id)))]
[name
(query-exec (current-conn) (update nutrients #:set [canonical_name ,name] #:where (= id ,id)))]
[formula
(query-exec (current-conn) (update nutrients #:set [formula ,formula] #:where (= id ,id)))]
[else (void)])
(or (get-nutrient #:id id) (error 'update-nutrient! "No nutrient with id ~a" id)))
;; DELETE
(define (delete-nutrient! nutrient)
(query-exec (current-conn) (delete #:from nutrients #:where (= id ,(nutrient-id nutrient)))))
|
