Support for rest arguments in signatures.

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```.
 

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)

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]")