;;;;
;;;; extract-doc.stk    -- Extrcat Documentation from STklos source files
;;;;
;;;; Copyright © 2000-2022 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)
;;;;

(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)                            (set! type 'extended))
          ((r57rs R57RS)                        (set! type 'r57rs-procedure))
          ((r7rs R7RS)                          (set! type 'r7rs-procedure))
          ((ext-syntax EXT-SYNTAX)              (set! type 'extended-syntax))
          ((r7rs-syntax R7RS-SYNTAX)            (set! type 'r7rs-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
;
;======================================================================

(let ((args (command-args)))
  (when (null? args)
    (die "Usage: extract-doc file ..."))

  ;;
  ;; "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\n" (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))
            args)
  (flush))
