;;; snarf-check-and-output-texi --- called by the doc snarfer.

;; Copyright (C) 2001, 2002, 2006, 2011, 2014, 2019 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
;; as published by the Free Software Foundation; either version 3, 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this software; see the file COPYING.LESSER.  If
;; not, write to the Free Software Foundation, Inc., 51 Franklin
;; Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Michael Livshin

;;; Code:

(define-module (scripts snarf-check-and-output-texi)
    :use-module (ice-9 streams)
    :use-module (ice-9 match)
    :export (snarf-check-and-output-texi))

(define %include-in-guild-list #f)
(define %summary "Transform snarfed .doc files into texinfo documentation.")

(define *manual-flag* #f)

(define (snarf-check-and-output-texi . flags)
  (if (member "--manual" flags)
      (set! *manual-flag* #t))
  (process-stream (current-input-port)))

(define (process-stream port)
  (let loop ((input (stream-map (match-lambda
                                 (('id . s)
                                  (cons 'id (string->symbol s)))
                                 (('int_dec . s)
                                  (cons 'int (string->number s)))
                                 (('int_oct . s)
                                  (cons 'int (string->number s 8)))
                                 (('int_hex . s)
                                  (cons 'int (string->number s 16)))
                                 ((and x (? symbol?))
                                  (cons x x))
                                 ((and x (? string?))
                                  (cons 'string x))
                                 (x x))
                                (make-stream (lambda (s)
                                               (let loop ((s s))
                                                 (cond
                                                   ((stream-null? s) #t)
                                                   ((memq (stream-car s) '(eol hash))
                                                    (loop (stream-cdr s)))
                                                   (else (cons (stream-car s) (stream-cdr s))))))
                                             (port->stream port read)))))

    (unless (stream-null? input)
      (let ((token (stream-car input)))
        (if (eq? (car token) 'snarf_cookie)
          (dispatch-top-cookie (stream-cdr input)
                               loop)
          (loop (stream-cdr input)))))))

(define (dispatch-top-cookie input cont)

  (when (stream-null? input)
    (error 'syntax "premature end of file"))

  (let ((token (stream-car input)))
    (cond
      ((eq? (car token) 'brace_open)
       (consume-multiline (stream-cdr input)
                          cont))
      (else
       (consume-upto-cookie process-singleline
                            input
                            cont)))))

(define (consume-upto-cookie process input cont)
  (let loop ((acc '()) (input input))

    (when (stream-null? input)
      (error 'syntax "premature end of file in directive context"))

    (let ((token (stream-car input)))
      (cond
        ((eq? (car token) 'snarf_cookie)
         (process (reverse! acc))
         (cont (stream-cdr input)))

        (else (loop (cons token acc) (stream-cdr input)))))))

(define (consume-multiline input cont)
  (begin-multiline)

  (let loop ((input input))

    (when (stream-null? input)
      (error 'syntax "premature end of file in multiline context"))

    (let ((token (stream-car input)))
      (cond
        ((eq? (car token) 'brace_close)
         (end-multiline)
         (cont (stream-cdr input)))

        (else (consume-upto-cookie process-multiline-directive
                                   input
                                   loop))))))

(define *file* #f)
(define *line* #f)
(define *c-function-name* #f)
(define *function-name* #f)
(define *snarf-type* #f)
(define *args* #f)
(define *sig* #f)
(define *docstring* #f)

(define (begin-multiline)
  (set! *file* #f)
  (set! *line* #f)
  (set! *c-function-name* #f)
  (set! *function-name* #f)
  (set! *snarf-type* #f)
  (set! *args* #f)
  (set! *sig* #f)
  (set! *docstring* #f))

(define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
(define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))

(define (end-multiline)
  (let* ((req (car *sig*))
         (opt (cadr *sig*))
         (var (caddr *sig*))
         (all (+ req opt var)))
    (if (and (not (eqv? *snarf-type* 'register))
             (not (= (length *args*) all)))
      (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
             *file* *line* *function-name* (length *args*) all)))
    (let ((nice-sig
            (if (eq? *snarf-type* 'register)
              *function-name*
              (with-output-to-string
                (lambda ()
                  (format #t "~A" *function-name*)
                  (let loop-req ((args *args*) (r 0))
                    (if (< r req)
                      (begin
                       (format #t " ~A" (car args))
                       (loop-req (cdr args) (+ 1 r)))
                      (let loop-opt ((o 0) (args args) (tail '()))
                       (if (< o opt)
                         (begin
                          (format #t " [~A" (car args))
                          (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
                         (begin
                          (if (> var 0)
                            (format #t " . ~A"
                                    (car args)))
                          (let loop-tail ((tail tail))
                               (if (not (null? tail))
                                 (begin
                                  (format #t "~A" (car tail))
                                  (loop-tail (cdr tail))))))))))))))
	  (scm-deffnx
	    (if (and *manual-flag* (eq? *snarf-type* 'primitive))
		(with-output-to-string
		  (lambda ()
                    (format #t "@deffnx {C Function} ~A (" *c-function-name*)
		    (unless (null? *args*)
		      (format #t "~A" (car *args*))
		      (let loop ((args (cdr *args*)))
			(unless (null? args)
			  (format #t ", ~A" (car args))
			  (loop (cdr args)))))
		    (format #t ")\n")))
		#f)))
      (format #t "\n