;;;;
;;;; extract-doc.stk	-- Extrcat Documentation from STklos source files
;;;;
;;;; Copyright © 2000-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 24-Nov-2000 11:08 (eg)
;;;; Last file update: 20-Apr-2011 10:24 (eg)
;;;;

(define start-doc-rgxp   	(string->regexp "^<doc "))
(define end-synopsys-rgxp 	(string->regexp "^ \\* *$"))
(define end-doc-rgxp		(string->regexp "^doc>"))

;======================================================================
;
;			parse-until-regexp
;
;======================================================================
(define (end-of-string s from)
  (let ((len (string-length s)))
    (substring s (min from len) len)))

(define (parse-until in proc)
  (let ((result '()))
    (do ((l (read-line in) (read-line in)))
	((or (eof-object? l) (proc l)))
      (set! result (if (null? result)
		       (list (end-of-string l 3))
		       `(,(end-of-string l 3) "\n" ,@result))))
    (apply string-append (reverse! result))))

;======================================================================
;
; 			parse-documentation-item
;
;======================================================================
(define (parse-documentation-item first-line in)

  (define (analyse-documentation-header first-line)
    (let ((in 	(open-input-string first-line))
	  (type #f)
	  (l    '()))
      (read in) ;; to skip "<doc"

      ;; Determine the type (procedure, syntax, ..) of this header
      (let ((item (read in)))
	(case  item
	  ((ext EXT R7RS) 			(set! type 'extended))
	  ((ext-syntax EXT-SYNTAX SYNTAX-R7RS)	(set! type 'extended-syntax))
	  ((syntax SYNTAX)			(set! type 'syntax))
	  (else					(set! type 'procedure)
						(set! l (list item)))))
      ;; Read all the item on the line
      (do ((proc (read in) (read in)))
	  ((eof-object? proc))
	(set! l (cons proc l)))

      ;; return a pair with the type in the car and the names in cdr.
      (cons type l)))

  (define (parse-synopsys in)
    (parse-until in (lambda (l) (regexp-match end-synopsys-rgxp l))))

  (define (parse-description in)
    (parse-until in (lambda (l) (regexp-match end-doc-rgxp l))))

  ;;
  ;; parse-proc-starts here
  ;;
  (let* ((infos (analyse-documentation-header first-line))
	 (type  (car infos))
	 (procs (cdr infos))
	 (syn   (parse-synopsys in))
	 (descr (parse-description in)))
    ;; Generate an entry for the first procedure of the list
    (format #t "(~S :type ~S :synopsis ~S :description ~S :similar ~S)\n\n"
	    (car procs) type syn descr (cdr procs))
    ;; Other procedures will use a :see entry
    (for-each (lambda(p) (format #t "(~S :see ~S)\n" p (car procs)))
	      (cdr procs))))

;======================================================================
;
; 			extract-doc-from-file
;
;======================================================================
(define (extract-doc-from-file f)
  (let ((in (open-input-file f)))
    (do ((l (read-line in) (read-line in)))
	((eof-object? l))
      (when (regexp-match start-doc-rgxp l)
	(parse-documentation-item l in)))
    (close-input-port in)))

;======================================================================
;
; 			Program starts here
;
;======================================================================
(when (null? (argv))
  (error "Usage: extract-doc file ...")
  (exit 1))

;;
;; "Create" the file on standard output (will be redirected in the Makefile)
;;
(format #t ";; **DO NOT EDIT**\t\t\t-*- scheme -*-\n")
(format #t ";; File generated automatically on ~A\n" (exec "date"))


(for-each (lambda (f)
	    (format (current-error-port) "Extracting documentation from ~A\n" f)
	    (format #t "\n;; Source file ~S\n\n" f)
	    (extract-doc-from-file f))
	  (argv))
(flush)
(exit 0)