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