;;
;; duck-extract.scm
;;
;; Duck - a CHICKEN in-source documentation: extraction tool.
;;
;; ISC License
;;
;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
;;
;; Permission to use, copy, modify, and/or distribute this software
;; for any purpose with or without fee is hereby granted, provided
;; that the above copyright notice and this permission notice appear
;; in all copies.
;; 
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
;;

(declare (unit duck-extract))

(module
 duck-extract
 (
  print-module-duck
  )

 (import scheme
	 (chicken base)
	 (chicken string)
	 (chicken format)
	 (chicken keyword)
	 util-proc)

 (define (print-duck-text dt)
   (print
    (string-intersperse
     (map (lambda (x)
	    (format "~A" x))
	  dt)
     " ")))

 (define (print-duck-module sec)
   (print "## " (cadr sec) " [module]")
   (newline)
   (print "    (import " (cadr sec) ")")
   (newline)
   (print-duck-text (caddr sec)))

 (define (print-duck-variable sec)
   (newline)
   (print "### " (cadr sec) " [variable]")
   (newline)
   (print "    (define " (cadr sec) " " (cadddr sec) ")")
   (newline)
   (print-duck-text (caddr sec)))

 (define (print-duck-parameter sec)
   (newline)
   (print "### " (cadr sec) " [parameter]")
   (newline)
   (print "    (define " (cadr sec) " (make-parameter " (list-ref sec 4) "))")
   (print "    (" (cadr sec) ")")
   (print "    (" (cadr sec) " " (cadddr sec) ")")
   (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 ~S"
								    (keyword->string kw)
								    (car cargs))
							    (format "~S" (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]")
   (newline)
   (print-duck-signature (cons (cadr sec) (cadddr sec)))
   (newline)
   (print-duck-text (caddr sec)))

 (define (print-duck-syntax sec)
   (newline)
   (print "### " (cadr sec) " [syntax]")
   (newline)
   (let loop ((patterns (cadddr sec)))
     (when (not (null? patterns))
       (print "    " (car patterns))
       (loop (cdr patterns))))
   (newline)
   (print-duck-text (caddr sec)))

 (define (print-duck-unknown sec)
   (print sec))

 (define (print-module-duck mod)
   (let loop ((mod mod))
     (when (not (null? mod))
       (when (car mod)
	 (case (caar mod)
	   ((MOD) (print-duck-module (car mod)))
	   ((VAR) (print-duck-variable (car mod)))
	   ((PAR) (print-duck-parameter (car mod)))
	   ((FUN) (print-duck-procedure (car mod)))
	   ((STX) (print-duck-syntax (car mod)))
	   (else (print-duck-unknown (car mod)))))
       (loop (cdr mod)))))

 )