diff --git a/doc/d-utils.md b/doc/d-utils.md index 400323d..59b22bd 100644 --- a/doc/d-utils.md +++ b/doc/d-utils.md @@ -44,7 +44,9 @@ CSV loader. ### (make-csv-line-parser separator string-delimiter) [procedure] - ((make-csv-line-parser separator string-delimiter) line) + ((make-csv-line-parser line) + separator + string-delimiter) Curried version of fast CSV line parser with given separator and string delimiter. @@ -54,13 +56,16 @@ Curried version of fast CSV line parser with given separator and string delimite ### csv-parse-lines [procedure] - (csv-parse-lines lines separator: (separator ;) string-delimiter: (string-delimiter ")) + (csv-parse-lines lines + #:separator (separator ;) + #:string-delimiter (string-delimiter ")) Parses given lines and returns list of lists of strings. ### csv-parse [procedure] - (csv-parse fn . args) + (csv-parse fn + . args) Uses ```csv-parse-lines``` on lines read from given file ```fn```. diff --git a/src/Makefile b/src/Makefile index bcadd01..7fdae6d 100644 --- a/src/Makefile +++ b/src/Makefile @@ -62,7 +62,7 @@ GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \ util-time.import.scm util-csv.import.scm GENDOC-OBJS=gendoc.o duck-extract.o util-time.o util-csv.o util-io.o \ - progress.o testing.o + progress.o testing.o util-proc.o .PHONY: imports imports: $(HACKERBASE-DEPS) @@ -511,7 +511,7 @@ DUCK-SOURCES=duck.scm duck.import.scm: $(DUCK-SOURCES) -DUCK-EXTRACT-SOURCES=duck-extract.scm +DUCK-EXTRACT-SOURCES=duck-extract.scm util-proc.import.scm duck-extract.o: duck-extract.import.scm duck-extract.import.scm: $(DUCK-EXTRACT-SOURCES) diff --git a/src/duck-extract.scm b/src/duck-extract.scm index 30c83fd..41b2aed 100644 --- a/src/duck-extract.scm +++ b/src/duck-extract.scm @@ -33,7 +33,9 @@ (import scheme (chicken base) (chicken string) - (chicken format)) + (chicken format) + (chicken keyword) + util-proc) (define (print-duck-text dt) (print @@ -43,9 +45,6 @@ dt) " "))) - (define (print-duck-signature sig) - (print " " sig)) - (define (print-duck-module sec) (print "## " (cadr sec) " [module]") (newline) @@ -71,6 +70,97 @@ (newline) (print-duck-text (caddr sec))) + (define (get-curry-depth sig) + (let loop ((sig sig) + (depth 0)) + (if (pair? sig) + (loop (car sig) + (add1 depth)) + depth))) + + (define (get-signature-name sig) + (let loop ((sig sig)) + (if (pair? sig) + (loop (car sig)) + sig))) + + (define (gather-signature-arguments sig) + (let loop ((sig sig) + (depth 1) + (args '())) + (if (pair? sig) + (loop (car sig) + (add1 depth) + (cons (cdr sig) + args)) + (reverse args)))) + + (define (expand-signature-arguments args) + (let loop ((args args) + (depth 1) + (res '())) + (if (null? args) + (apply append (reverse res)) + (let-values (((count rest?) (improper-list-info (car args)))) + (loop (cdr args) + (add1 depth) + (cons (let aloop ((cargs (car args)) + (c (if rest? (add1 count) count)) + (kw #f) + (ar '())) + (if (null? cargs) + (reverse ar) + (if (symbol? cargs) + (aloop '() + (sub1 c) + #f + (cons (list (format ". ~A" cargs) depth #t) + ar)) + (if (keyword? (car cargs)) + (aloop (cdr cargs) + (sub1 c) + (car cargs) + ar) + (aloop (cdr cargs) + (sub1 c) + #f + (cons (list (if kw + (format "#:~A ~A" + (keyword->string kw) + (car cargs)) + (format "~A" (car cargs))) + depth + (= c 1)) + ar)))))) + res)))))) + + (define (print-duck-signature sig) + ;;(print sig) + (let* ((curry-depth (get-curry-depth sig)) + (name (get-signature-name sig)) + (nameline (format " ~A~A" (make-string curry-depth #\() name)) + (spaceline (make-string (add1 (string-length nameline)) #\space)) + (args (gather-signature-arguments sig)) + (eargs (expand-signature-arguments args))) + ;;(print " curry depth = " curry-depth) + ;;(print " name = " name) + ;;(print " args = " args) + ;;(printf " eargs = ~S" eargs) + ;;(newline) + (if (null? eargs) + (print nameline ")") + (let loop ((args eargs) + (first #t)) + (when (not (null? args)) + (print (if first + (format "~A " nameline) + spaceline) + (caar args) + (if (caddar args) ")" "") + ) + (loop (cdr args) + #f)))))) + (define (print-duck-procedure sec) (newline) (print "### " (cadr sec) " [procedure]")