blob: c6bc13711963a3b055127f3b5160e8f4c2998a38 (
plain)
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
|
#lang racket
(require "../../shared/data-directed-programming.rkt")
(require "../../shared/lists.rkt")
(define test-dispatch (make-dispatch-table))
(define get (getter test-dispatch))
(define put (putter test-dispatch))
;; Example implementations
(define test-division (attach-tag
'division-a
(list (attach-tag
'henk
(list (attach-tag 'salary 100))))))
(put 'record 'division-a (lambda (file-set employee)
(let ((record (find-first
(make-eq-type? employee)
file-set)))
(if record
record
(error "Employee record not found -- GET-RECORD DIVISION-A" employee)))))
(put 'salary 'division-a (lambda (record)
(let ((salary (find-first
(make-eq-type? 'salary)
record)))
(if salary
salary
(error "Salary not found -- GET-SALARY DIVISION-A" record)))))
;;a Each divisions file must be a datum tagged with the divisions name.
;; Together with the division type tag and an operation type tag
;; we can get a procedure that knows how to do that operation for the given employee.
(define (get-record file employee)
((get 'record (type-tag file)) (contents file) employee))
(define test-record (get-record test-division 'henk))
;; b The record can have any structure that is handled by the salary procedure of the
;; division we dispatch the procedure from
(define (get-salary file record)
((get 'salary (type-tag file)) (contents record)))
(get-salary test-division test-record)
;;c
(define (find-employee-record files employee)
(define (search fi)
(if (null? fi)
false
(let ((result (with-handlers
([exn:fail? (lambda (exn)
false)])
(get-record (car fi) employee))))
(if result
result
(search (cdr fi))))))
(search files))
(find-employee-record (list test-division test-division) 'henk)
;;d
;; new implementations for the division representation for the existing operations on a type
|
