199 lines
5 KiB
Scheme
199 lines
5 KiB
Scheme
;;
|
|
;; 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)))))
|
|
|
|
)
|