;; TODO: add table, list directives
(import (only chicken.process-context command-line-arguments)
(only getopt-long getopt-long usage)
(only chicken.format printf sprintf)
(only chicken.io read-string read-line)
(only chicken.port call-with-input-string)
(only chicken.file file-exists? directory)
(only chicken.pathname
make-pathname
pathname-directory
pathname-extension
pathname-file)
(only srfi-1
find
filter
first second third fourth fifth sixth)
(only srfi-13
string-prefix?
string-trim
string-trim-both))
(define grammar
'((help "Print usage"
(required #f)
(single-char #\h))
(output "Write to file"
(required #f)
(single-char #\o)
(value (required FILE)))
(ignore-egg "Ignore .egg file"
(required #f)
(single-char #\i))
(ignore-release "Ignore .release-info file"
(required #f)
(single-char #\r))
(no-toc "Don't add a toc"
(required #f)
(single-char #\n))
(email "Include EMAIL with author"
(required #f)
(single-char #\e)
(value (required EMAIL)))
(head "File to add to beginning of documentation"
(required #f)
(single-char #\H)
(value (required FILE)))
(prologue "File to add after synopsis"
(required #f)
(single-char #\P)
(value (required FILE)))
(epilogue "File to add before maintainer info"
(required #f)
(single-char #\E)
(value (required FILE)))
(tail "File to add to end of documentation"
(required #f)
(single-char #\T)
(value (required FILE)))
(license "Whether to insert a license"
(required #f)
(single-char #\L)
(value (optional FILE)))
(module-headers "Create === Module-name headers"
(required #f)
(single-char #\m))))
(define (print-usage #!optional (code 0))
(printf "Usage: chalk [OPTION]... [FILE]...\n")
(printf (usage grammar))
(exit code))
(define pargs
(getopt-long (command-line-arguments) grammar
#:unknown-option-handler (lambda (c)
(print-usage 1))))
(define input-files (alist-ref '@ pargs))
(define (find-tag tag doc)
(find (lambda (i)
(and (pair? i)
(not (null? i))
(equal? (car i) tag)))
doc))
(define (find-docstr doc)
(find string? doc))
(define (document-procedure exp #!optional (type 'procedure))
(let* ((doc (fourth exp))
(internal (find-tag '@internal doc)))
(unless internal
(let* ((sig-tag (find-tag '@sig doc))
(sig (or (and sig-tag (cadr sig-tag))
(second exp)))
(docstr (find-docstr doc))
(@to (find-tag '@to doc))
(@example (find-tag '@example doc))
(params (filter
(lambda (e)
(and (pair? e)
(not (string-prefix? "@"
(symbol->string (car e))))))
doc)))
(if @to
(printf "<~a>~s → ~a~a>\n" type sig (cadr @to) type)
(printf "<~a>~s~a>\n" type sig type))
(when docstr
(printf "~a\n\n" docstr))
(when (not (null? params))
(document-deflist params))
(when @example
(document-script (cons '(@highlight "scheme") @example)))))))
(define (document-variable exp)
(let* ((name (second exp))
(doc (fourth exp))
(internal (find-tag '@internal doc))
(docstr (find-docstr doc)))
(unless internal
(printf "~s\n" name)
(when docstr
(printf "~a\n\n" docstr)))))
(define (document-record exp)
(let* ((type (first exp))
(name (second exp))
(rec-doc (fourth exp))
(internal (find-tag '@internal rec-doc))
(docstr (find-docstr rec-doc))
(full (find-tag '@full rec-doc)))
(unless internal
(printf "~s\n" name)
(when full
(if (eqv? type 'define-record)
(begin
(printf "~a\n" (cons (sprintf "make-~a" name)
(cddddr exp)))
(printf "~a?\n" name)
(for-each
(lambda (e)
(printf "~a-~a\n" name e))
(cddddr exp)))
(begin
(printf "~a\n" (fifth exp))
(printf "~a\n" (sixth exp))
(for-each
(lambda (e)
(printf "~a\n" (cadr e))
(when (not (or (null? (cddr e))
(pair? (caddr e))))
(printf "~a\n" (caddr e))))
(cddr (cddddr exp)))
)))
(when docstr
(printf "~a\n\n" docstr)))))
(define procedure-tags
'(fn proc procedure function))
(define syntax-tags
'(macro syntax))
(define file-relpath)
(define (document-expr exp)
(define documentable-expr?
(and (not (null? (cddr exp)))
(not (null? (cdddr exp)))
(eqv? '@ (third exp))
(not (null? (fourth exp)))))
(when (and (pair? exp)
(not (null? (cdr exp))))
(cond ((and documentable-expr?
(or (member (car (fourth exp)) syntax-tags)
(eqv? 'define-syntax (first exp))))
(document-procedure exp 'syntax))
((and documentable-expr?
(or (member (car (fourth exp)) procedure-tags)
(and (eqv? 'define (first exp))
(pair? (second exp)))))
(document-procedure exp))
((and documentable-expr?
(eqv? 'define (car exp)))
;; (print "VRA")
(document-variable exp))
((and documentable-expr?
(or (eqv? 'define-record (car exp))
(eqv? 'define-record-type (car exp))))
(document-record exp))
((eqv? 'include (car exp))
;; (print "HEY")
(document-file (cadr exp)))
((eqv? 'include-relative (car exp))
(document-file (make-pathname file-relpath (cadr exp)))))))
(define (document-script script-exp)
(let ((docstr (find-docstr script-exp))
(highlight (find-tag '@highlight script-exp))
(pre (find-tag '@pre script-exp))
(post (find-tag '@post script-exp)))
(unless (not docstr)
(when pre
(printf "~a\n" (cadr pre)))
(printf "\n"
(if highlight
(sprintf " highlight=\"~a\"" (cadr highlight))
""))
(printf "~a\n" (string-trim-both docstr))
(printf "\n\n")
(when post
(printf "~a\n" (cadr post))))))
(define (document-deflist list-exp)
(for-each
(lambda (kv)
(let ((term (car kv))
(def (cdr kv)))
(if (null? def)
(printf "; ~a :\n" term)
(printf "; ~a : ~a\n" term (car def)))))
list-exp)
(newline))
(define (document-free exp)
(unless (null? exp)
(let ((docstr (find-docstr exp)))
(case (car exp)
((script)
(document-script exp))
((heading title ==)
(printf "== ~a\n\n" docstr))
((subheading subtitle ===)
(printf "=== ~a\n\n" docstr))
((subsubheading subsubtitle ====)
(printf "==== ~a\n\n" docstr))
((subsubsubsubheading subsubsubsubtitle =====)
(printf "===== ~a\n\n" docstr))
((deflist)
(document-deflist (cdr exp)))
(else
(printf "~a\n\n" docstr))))))
(define (document-module exp)
(when (alist-ref 'module-headers pargs)
(let ((module-name (cadr exp)))
(printf "=== Module: ~s\n" module-name)))
(let loop ((exp (cdddr exp)))
(cond ((null? exp) (void))
((eqv? (car exp) '@)
(document-free (cadr exp))
(loop (cddr exp)))
(else
(document-expr (car exp))
(loop (cdr exp))))))
(define (document-file file)
(set! file-relpath (pathname-directory file))
(call-with-input-file file
(lambda (in)
(let loop ((exp (read in)))
(cond ((eof-object? exp)
(void))
((and (pair? exp)
(eqv? (car exp) 'module))
(document-module exp)
(loop (read in)))
((eqv? '@ exp)
(document-free (read in))
(loop (read in)))
(else
(document-expr exp)
(loop (read in))))))))
(define (generate-docs #!optional (output (current-output-port)))
(do ((files input-files (cdr files)))
((null? files))
(let ((file (car files)))
(document-file file))))
(when (alist-ref 'help pargs)
(print-usage))
(define outfile (alist-ref 'output pargs))
(define license (alist-ref 'license pargs))
(define head (alist-ref 'head pargs))
(define tail (alist-ref 'tail pargs))
(define prologue (alist-ref 'prologue pargs))
(define epilogue (alist-ref 'epilogue pargs))
(define egg-file (find (lambda (f)
(equal? (pathname-extension f) "egg"))
(directory)))
(define egg-name (if egg-file (pathname-file egg-file) #f))
(define release-file (if egg-name (make-pathname #f egg-name "release-info")))
(define ignore-egg (alist-ref 'ignore-egg pargs))
(define no-toc (alist-ref 'no-toc pargs))
(define ignore-release (alist-ref 'ignore-release pargs))
(define email (alist-ref 'email pargs))
;; let* ((outfile (alist-ref 'output pargs))
;; (license (alist-ref 'license pargs))
;; (prologue (alist-ref 'prologue pargs))
;; (epilogue (alist-ref 'epilogue pargs))
;; (egg-file (find (lambda (f)
;; (equal? (pathname-extension f) "egg"))
;; (directory)))
;; (egg-name (if egg-file (pathname-file egg-file) #f)))
(when outfile
(current-output-port (open-output-file outfile)))
(when head
(if (file-exists? head)
(call-with-input-file head
(lambda (in)
(let ((str (read-string #f in)))
(printf str))))
(warning "Head file not found, skipping...")))
(unless (or ignore-egg (not egg-file))
(printf "[[tags: egg]]\n")
(unless no-toc
(printf "[[toc:]]\n"))
(printf "== ~a\n" egg-name)
(call-with-input-file egg-file
(lambda (in)
(let* ((values (read in))
(synopsis (alist-ref 'synopsis values)))
(when synopsis
(printf "~a\n\n" (car synopsis)))))))
(when prologue
(if (file-exists? prologue)
(call-with-input-file prologue
(lambda (in)
(let ((str (read-string #f in)))
(printf str))))
(warning "Prologue file not found, skipping...")))
(generate-docs)
(when epilogue
(if (file-exists? epilogue)
(call-with-input-file epilogue
(lambda (in)
(let ((str (read-string #f in)))
(printf str))))
(warning "Epilogue file not found, skipping...")))
(unless (or ignore-egg (not egg-file))
(call-with-input-file egg-file
(lambda (in)
(let* ((values (read in))
(author (alist-ref 'author values))
(maintainer (alist-ref 'maintainer values)))
(when maintainer
(printf "=== Maintainer\n")
(printf "~a\n" (car maintainer)))
(when author
(printf "=== Author\n")
(printf "~a\n" (car author))
(when email
(printf "~a\n" email))
(newline))))))
(when license
(let ((license-file (or (and (string? license)
license)
"LICENSE")))
(if (file-exists? license-file)
(begin
(printf "=== License\n")
(call-with-input-file license-file
(lambda (in)
(let ((str (read-string #f in)))
(printf str)
(newline)))))
(warning "License file not found, skipping..."))))
(unless (or ignore-egg ignore-release)
(if (file-exists? release-file)
(begin
(printf "=== Version History\n")
(call-with-input-file release-file
(lambda (in)
(let loop ((line (read-line in)))
(unless (eof-object? line)
(call-with-input-string
line
(lambda (line-in)
(let ((expr (read line-in)))
(when (and (not (eof-object? expr))
(eqv? (car expr) 'release))
(printf "; ~a :~a\n"
(cadr expr)
(let ((descr (read-string #f line-in)))
(if (eof-object? descr)
""
(sprintf
" ~a"
(string-trim
descr
(lambda (c)
(or (char-whitespace? c)
(char=? c #\;)))))))
)))))
(loop (read-line in)))))))
(warning "release-info file not found, skipping...")))
(when tail
(if (file-exists? tail)
(call-with-input-file tail
(lambda (in)
(let ((str (read-string #f in)))
(printf str))))
(warning "Tail file not found, skipping...")))
(close-output-port (current-output-port))