#!/usr/bin/guile \
-e "(scripts snarf-check-and-output-texi)" -s
!#
;;; snarf-check-and-output-texi --- called by the doc snarfer.

;; 	Copyright (C) 2001,2003,2004 Free Software Foundation, Inc.
;;
;; 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, 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 software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Michael Livshin

;;; Commentary:

;; Usage: snarf-check-and-output-texi FILE ...
;;
;; TODO: Write better commentary.

;;; Code:

(define-module (scripts snarf-check-and-output-texi)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:autoload  (ice-9 streams) (stream-map make-stream)
  ;; currently not available (this program is broken)
  ;;    #:use-module (ice-9 match)
  #:export (snarf-check-and-output-texi))

;;; why aren't these in some module?

(define-macro (when cond . body)
  `(if ,cond (begin ,@body)))

(define-macro (unless cond . body)
  `(if (not ,cond) (begin ,@body)))

(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)
                                                  ((eq? 'eol (stream-car s))
                                                   (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 (simple-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 ()
                   (simple-format #t "~A" *function-name*)
                   (let loop-req ((args *args*) (r 0))
                     (if (< r req)
                         (begin
                           (simple-format #t " ~A" (car args))
                           (loop-req (cdr args) (+ 1 r)))
                         (let loop-opt ((o 0) (args args) (tail '()))
                           (if (< o opt)
                               (begin
                                 (simple-format #t " [~A" (car args))
                                 (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
                               (begin
                                 (if (> var 0)
                                     (simple-format #t " . ~A"
                                                    (car args)))
                                 (let loop-tail ((tail tail))
                                   (if (not (null? tail))
                                       (begin
                                         (simple-format #t "~A" (car tail))
                                         (loop-tail (cdr tail))))))))))))))
	  (scm-deffnx
           (if (and *manual-flag* (eq? *snarf-type* 'primitive))
               (with-output-to-string
                 (lambda ()
                   (simple-format #t "@deffnx {C Function} ~A (" *c-function-name*)
                   (unless (null? *args*)
                     (simple-format #t "~A" (car *args*))
                     (let loop ((args (cdr *args*)))
                       (unless (null? args)
                         (simple-format #t ", ~A" (car args))
                         (loop (cdr args)))))
                   (simple-format #t ")\n")))
               #f)))
      (simple-format #t "\n~A\n" *function-name*)
      (simple-format #t "@c snarfed from ~A:~A\n" *file* *line*)
      (simple-format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
      (let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
	(cond ((null? strings))
	      ((or (not scm-deffnx)
		   (and (>= (string-length (car strings))
			    *primitive-deffnx-sig-length*)
			(string=? (substring (car strings)
					     0 *primitive-deffnx-sig-length*)
				  *primitive-deffnx-signature*)))
	       (display (car strings))
	       (loop (cdr strings) scm-deffnx))
	      (else (display scm-deffnx)
		    (loop strings #f))))
      (display "\n")
      (display "@end deffn\n"))))

(define (texi-quote s)
  (let rec ((i 0))
    (if (= i (string-length s))
        ""
        (string-append (let ((ss (substring s i (+ i 1))))
                         (if (string=? ss "@")
                             "@@"
                             ss))
                       (rec (+ i 1))))))

(define (process-multiline-directive l)

  (define do-args
    (match-lambda

     (('(paren_close . paren_close))
      '())

     (('(comma . comma) rest ...)
      (do-args rest))

     (('(id . SCM) ('id . name) rest ...)
      (cons name (do-args rest)))

     (x (error (simple-format #f "invalid argument syntax: ~A" (map cdr x))))))

  (define do-arglist
    (match-lambda

     (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
      '())

     (('(paren_open . paren_open) rest ...)
      (do-args rest))

     (x (error (simple-format #f "invalid arglist syntax: ~A" (map cdr x))))))

  (define do-command
    (match-lambda

     (('cname ('id . name))
      (set! *c-function-name* (texi-quote (symbol->string name))))

     (('fname ('string . name))
      (set! *function-name* (texi-quote name)))

     (('type ('id . type))
      (set! *snarf-type* type))

     (('type ('int . num))
      (set! *snarf-type* num))

     (('location ('string . file) ('int . line))
      (set! *file* file)
      (set! *line* line))

     (('arglist rest ...)
      (set! *args* (do-arglist rest)))

     (('argsig ('int . req) ('int . opt) ('int . var))
      (set! *sig* (list req opt var)))

     (x (error (simple-format #f "unknown doc attribute: ~A" x)))))

  (define do-directive
    (match-lambda

     ((('id . command) rest ...)
      (do-command (cons command rest)))

     ((('string . string) ...)
      (set! *docstring* string))

     (x (error (simple-format #f "unknown doc attribute syntax: ~A" x)))))

  (do-directive l))

(define (process-singleline l)

  (define do-argpos
    (match-lambda
     ((('id . name) ('int . pos) ('int . line))
      (let ((idx (list-index *args* name)))
        (when idx
          (unless (= (+ idx 1) pos)
            (display (simple-format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
                                    *file* line name pos (+ idx 1))
                     (current-error-port))))))
     (x #f)))

  (define do-command
    (match-lambda
     (('(id . argpos) rest ...)
      (do-argpos rest))
     (x (error (simple-format #f "unknown check: ~A" x)))))

  (when *function-name*
    (do-command l)))

(define (main args)
  (HVQC-MAIN args (lambda (args)
                    (apply snarf-check-and-output-texi (cdr args)))
             '(usage . commentary)
             '(package . "Guile")))

;;; snarf-check-and-output-texi ends here
