1(library (yuni util tables scheme)
2         (export
3           table-metadata
4           table-slots
5           table/scheme
6           table-map
7           table-fold
8           table-for-each
9           table-metadata-ref
10           file->table-list
11           list->table)
12         (import (rnrs)
13                 (srfi :8)
14                 (shorten)
15                 (yuni util files)
16                 (yuni core))
17
18(define* table/scheme
19  (metadata slots entry*))
20
21(define (list->table l) ;; => table
22  (define (make-metadata cur p)
23    (if (pair? p)
24      (let ((e (car p))
25            (rest (cdr p)))
26        (if (or (vector? e)
27                (null? e))
28          (reverse cur)
29          (make-metadata (cons e cur) rest)))
30      (reverse cur)))
31  (define (slots+entries l)
32    (if (pair? l)
33      (let ((a (car l))
34            (b (cdr l)))
35        (if (vector? a)
36          (values a b)
37          (slots+entries b)))
38      '()))
39  (define (search-slots l)
40    (receive (slots entries) (slots+entries l)
41      slots))
42  (define (search-entries l)
43    (receive (slots entries) (slots+entries l)
44      entries))
45  (make table/scheme
46        (metadata (make-metadata '() l))
47        (slots (search-slots l))
48        (entry* (map list->vector (search-entries l)))))
49
50(define (file->table-list fn)
51  (let ((f (file->sexp-list fn)))
52    (map list->table f)))
53
54(define* (table-metadata (tbl table/scheme))
55  (let-with tbl (metadata) metadata))
56
57(define* (table-slots (tbl table/scheme))
58  (let-with tbl (slots) slots))
59
60(define* (table-metadata-ref (tbl table/scheme) slot)
61  (define (search l)
62    (if (pair? l)
63      (let ((e (car l))
64            (rest (cdr l)))
65        (if (pair? e)
66          (let ((s (car e))
67                (value (cdr e)))
68            (if (eq? s slot)
69              (if (and (list? value) (= 1 (length value)))
70                (car value)
71                value)
72              (search rest)))
73          (if (eq? e slot)
74            #t
75            (search rest))))
76      #f))
77  (let ((metadata (table-metadata tbl)))
78    (search metadata)))
79
80(define (syms->idx slots syms)
81  (define (one sym)
82    (define (itr idx cur)
83      (if (pair? cur)
84        (if (eq? (car cur) sym)
85          idx
86          (itr (+ 1 idx) (cdr cur)))
87        #f))
88    (itr 0 (vector->list slots)))
89  (map one syms))
90
91(define (make-lookup slots syms)
92  (let ((idx* (syms->idx slots syms)))
93    (^[entry]
94      (define (one idx)
95        (if (or (not idx) (>= idx (vector-length entry)))
96          #f
97          (vector-ref entry idx)))
98      (map one idx*))))
99
100(define (make-lookup/fold slots syms)
101  (let ((idx* (syms->idx slots syms)))
102    (^[cur entry]
103      (define (one idx)
104        (if (or (not idx) (>= idx (vector-length entry)))
105          #f
106          (vector-ref entry idx)))
107      (let ((r (map one idx*)))
108        ;; FIXME: use values...
109        (cons cur r)))))
110
111(define* (table-for-each (tbl table/scheme) syms proc)
112  (let-with tbl (slots entry*)
113    (let ((lookup (make-lookup slots syms)))
114      (for-each (^e (apply proc (lookup e)))
115                entry*))))
116
117(define* (table-fold (tbl table/scheme) syms proc knil)
118  (let-with tbl (slots entry*)
119    (let ((lookup (make-lookup/fold slots syms)))
120      (fold-left (^[cur e]
121                   (apply proc (lookup cur e)))
122                 knil
123                 entry*))))
124
125(define* (table-map (tbl table/scheme) syms proc)
126  (reverse (table-fold tbl syms
127                       (^ m (let ((cur (car m))
128                                  (param (cdr m)))
129                              (cons (apply proc param) cur)))
130                       '())))
131)
132