summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xparse.scm113
1 files changed, 51 insertions, 62 deletions
diff --git a/parse.scm b/parse.scm
index 8c8287a..40d4814 100755
--- a/parse.scm
+++ b/parse.scm
@@ -21,56 +21,24 @@
(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))))
+(define (read-csv port)
+ "Read from port into a peg:tree."
+ (let* ((rawstr (read-delimited "" port))
+ (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)
+ "Get data from field-part cells"
(if (symbol? part)
- (format #t "ERR: ~s~%" part)
+ #f
(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)
@@ -80,24 +48,45 @@ otherwise return the full list"
(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)))))
+;; ('line ('field ('field-part data) ...) ...)
+;; -> ({(data ...) | data} ...)
+(define (clean-peg-tree tree)
+ "Clean up input from read-csv, returns a more bare bones tree"
+ (map (lambda (line) ; for every line
+ (ensure-symbol (car line) 'line)
+ (map (lambda (field) ; for every field in line
+ (and (not (symbol? field)) ; if a symbol no data is present
+ ;; else extract the data
+ (begin (ensure-symbol (car field) 'field)
+ (flatten-1 (map get-part-data (cdr field))))))
+ (cdr line)))
+ tree))
+
+;;; Takes (car (clean-peg-tree csv))
+;;; name is a string
+;;; returns a record-type, a constructor, a predicate procedure,
+;;; and an association list of getters
+(define (create-csv-record name field-strings)
+ "Creates datatypes from csv records"
+ (let ((full-name (string-append "csv:" name))
+ (fields (map string->symbol field-strings)))
+ (let* ((record-type (make-record-type full-name fields))
+ (make-record (record-constructor record-type fields))
+ (predicate (record-predicate record-type))
+ (accessors (map cons fields
+ (map (cut record-accessor record-type <>)
+ fields))))
+ (values record-type make-record predicate accessors))))
+
+;;; filename -> [book]
+(define (load-data csv-file-name)
+ (let* ((csv (call-with-input-file csv-file-name read-csv))
+ (tree (clean-peg-tree csv))
+ (fields (car tree))
+ (data (cdr tree)))
+ (receive (book make-book book? book-getters)
+ (create-csv-record "book" fields)
+ (map (cut apply make-book <>)
+ data))))
+
+