blob: 8c8287a769bd1fea5ef2bd90bb656d91dafb9a51 (
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
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
|
#!/usr/bin/guile \
-e main -s
!#
(add-to-load-path (dirname (current-filename)))
(use-modules (srfi srfi-1)
(srfi srfi-8)
(srfi srfi-9)
(srfi srfi-26)
(ice-9 rdelim)
(ice-9 peg)
(patterns))
;; var is the field to test
;; symb is the expected value
(define-syntax-rule (ensure-symbol var symb)
(unless (eqv? var symb)
(throw 'symbol-not-equal "Expected ~s, got ~s~%" symb var)))
(define (load-csv filename)
(with-input-from-file filename
(lambda ()
(let* ((rawstr (read-delimited ""))
(match (match-pattern file rawstr))
(tree (keyword-flatten '(line)
(peg:tree match))))
tree))))
;;; TODO sometimes part is a symbol instead of a list,
;;; somehow an earlier part got consed on? or something?
(define (get-part-data part)
(if (symbol? part)
(format #t "ERR: ~s~%" part)
(begin
(ensure-symbol (car part) 'field-part)
(cadr part))))
;; ('line ('field ('field-part data) ...) ...) -> ({(data ...) | data} ...)
(define (clean-peg-tree tree)
(map (lambda (line)
(ensure-symbol (car line) 'line)
(let ((fields (cdr line)))
(map (lambda (field)
(if (symbol? field)
#f
(begin (ensure-symbol (car field) 'field)
(map get-part-data (cdr field)))))
fields)))
tree))
;; record-name should be a symbol
(define (create-csv-type record-name first-line)
(let ((strname (string-append
"csv:"
(symbol->string record-name)))
(l (car first-line))
(rawfields (cdr first-line)))
(ensure-symbol l 'line)
(let ((fields
(map (lambda (field)
(ensure-symbol (car field) 'field)
(let ((rest (cadr field)))
(ensure-symbol (car rest) 'field-part)
(string->symbol (cadr rest))))
rawfields)))
(let* ((record-type (make-record-type strname fields))
(make-record (record-constructor record-type fields))
(predicate record-type))
(values record-type make-record predicate)))))
(define (flatten-1 lst)
"If list is of length one return the first element,
otherwise return the full list"
(if (= 1 (length lst))
(car lst)
lst))
(define (get-db filename)
(let ((doc (load-csv filename)))
(receive (book make-book book?)
(create-csv-type 'book (car doc))
(map (lambda (line) ; returns a record
(ensure-symbol (car line) 'line)
(apply make-book
(map (lambda (field) ; returns a list or #f
(if (symbol? field)
#f
(begin
(ensure-symbol (car field) 'field)
(flatten-1
(map (lambda (part) ; returns [string]
(ensure-symbol (car part) 'field-part)
(cadr part))
(cdr field)))))
#; (cadr field)
)
(cdr line))))
(cdr doc)))))
|
