[bpt/guile.git] / module / scripts / snarf-check-and-output-texi.scm

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

;; Copyright (C) 2001, 2002, 2006, 2011, 2014 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.")

;;; 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)
                                                   ((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\f~A\n" *function-name*)
      (format #t "@c snarfed from ~A:~A\n" *file* *line*)
      (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 (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 (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 (apply string-append 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 (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 (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 (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 (format #f "unknown check: ~A" x)))))

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

(define main snarf-check-and-output-texi)
Commit	Line	Data
13482e95 ML	1	;;; snarf-check-and-output-texi --- called by the doc snarfer.
13482e95 ML	2
c3c30326	3	;; Copyright (C) 2001, 2002, 2006, 2011, 2014 Free Software Foundation, Inc.
13482e95 ML	4	;;
13482e95 ML	5	;; This program is free software; you can redistribute it and/or
83ba2d37 NJ	6	;; modify it under the terms of the GNU Lesser General Public License
83ba2d37 NJ	7	;; as published by the Free Software Foundation; either version 3, or
13482e95 ML	8	;; (at your option) any later version.
	9	;;
	10	;; This program is distributed in the hope that it will be useful,
	11	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
83ba2d37	13	;; Lesser General Public License for more details.
13482e95	14	;;
83ba2d37 NJ	15	;; You should have received a copy of the GNU Lesser General Public
	16	;; License along with this software; see the file COPYING.LESSER. If
	17	;; not, write to the Free Software Foundation, Inc., 51 Franklin
	18	;; Street, Fifth Floor, Boston, MA 02110-1301 USA
13482e95	19
61897afe TTN	20	;;; Author: Michael Livshin
61897afe TTN	21
13482e95 ML	22	;;; Code:
	23
	24	(define-module (scripts snarf-check-and-output-texi)
58e17e27 ML	25	:use-module (ice-9 streams)
58e17e27 ML	26	:use-module (ice-9 match)
13482e95 ML	27	:export (snarf-check-and-output-texi))
13482e95 ML	28
a1a2ed53 AW	29	(define %include-in-guild-list #f)
	30	(define %summary "Transform snarfed .doc files into texinfo documentation.")
	31
58e17e27 ML	32	;;; why aren't these in some module?
	33
	34	(define-macro (when cond . body)
	35	`(if ,cond (begin ,@body)))
	36
	37	(define-macro (unless cond . body)
	38	`(if (not ,cond) (begin ,@body)))
	39
cecb4a5e NJ	40	(define manual-flag #f)
	41
	42	(define (snarf-check-and-output-texi . flags)
e21f90f0	43	(if (member "--manual" flags)
cecb4a5e	44	(set! manual-flag #t))
58e17e27 ML	45	(process-stream (current-input-port)))
	46
	47	(define (process-stream port)
	48	(let loop ((input (stream-map (match-lambda
	49	(('id . s)
	50	(cons 'id (string->symbol s)))
	51	(('int_dec . s)
	52	(cons 'int (string->number s)))
	53	(('int_oct . s)
	54	(cons 'int (string->number s 8)))
	55	(('int_hex . s)
	56	(cons 'int (string->number s 16)))
	57	((and x (? symbol?))
	58	(cons x x))
	59	((and x (? string?))
	60	(cons 'string x))
	61	(x x))
	62	(make-stream (lambda (s)
	63	(let loop ((s s))
	64	(cond
	65	((stream-null? s) #t)
c3c30326	66	((memq (stream-car s) '(eol hash))
58e17e27 ML	67	(loop (stream-cdr s)))
	68	(else (cons (stream-car s) (stream-cdr s))))))
	69	(port->stream port read)))))
aa3eb769	70
58e17e27 ML	71	(unless (stream-null? input)
	72	(let ((token (stream-car input)))
	73	(if (eq? (car token) 'snarf_cookie)
	74	(dispatch-top-cookie (stream-cdr input)
	75	loop)
	76	(loop (stream-cdr input)))))))
	77
	78	(define (dispatch-top-cookie input cont)
aa3eb769	79
58e17e27 ML	80	(when (stream-null? input)
58e17e27 ML	81	(error 'syntax "premature end of file"))
aa3eb769	82
58e17e27 ML	83	(let ((token (stream-car input)))
	84	(cond
	85	((eq? (car token) 'brace_open)
	86	(consume-multiline (stream-cdr input)
	87	cont))
	88	(else
	89	(consume-upto-cookie process-singleline
	90	input
	91	cont)))))
	92
	93	(define (consume-upto-cookie process input cont)
	94	(let loop ((acc '()) (input input))
aa3eb769	95
58e17e27 ML	96	(when (stream-null? input)
58e17e27 ML	97	(error 'syntax "premature end of file in directive context"))
aa3eb769	98
58e17e27 ML	99	(let ((token (stream-car input)))
	100	(cond
	101	((eq? (car token) 'snarf_cookie)
	102	(process (reverse! acc))
	103	(cont (stream-cdr input)))
	104
	105	(else (loop (cons token acc) (stream-cdr input)))))))
	106
	107	(define (consume-multiline input cont)
	108	(begin-multiline)
	109
	110	(let loop ((input input))
	111
	112	(when (stream-null? input)
	113	(error 'syntax "premature end of file in multiline context"))
aa3eb769	114
58e17e27 ML	115	(let ((token (stream-car input)))
	116	(cond
	117	((eq? (car token) 'brace_close)
	118	(end-multiline)
	119	(cont (stream-cdr input)))
aa3eb769	120
58e17e27 ML	121	(else (consume-upto-cookie process-multiline-directive
	122	input
	123	loop))))))
	124
13482e95 ML	125	(define file #f)
13482e95 ML	126	(define line #f)
cecb4a5e	127	(define c-function-name #f)
13482e95 ML	128	(define function-name #f)
	129	(define snarf-type #f)
	130	(define args #f)
	131	(define sig #f)
	132	(define docstring #f)
	133
58e17e27 ML	134	(define (begin-multiline)
	135	(set! file #f)
	136	(set! line #f)
cecb4a5e	137	(set! c-function-name #f)
58e17e27 ML	138	(set! function-name #f)
	139	(set! snarf-type #f)
	140	(set! args #f)
	141	(set! sig #f)
	142	(set! docstring #f))
aa3eb769	143
8f85c0c6	144	(define primitive-deffnx-signature "@deffnx {Scheme Procedure} ")
cecb4a5e NJ	145	(define primitive-deffnx-sig-length (string-length primitive-deffnx-signature))
cecb4a5e NJ	146
58e17e27	147	(define (end-multiline)
13482e95 ML	148	(let* ((req (car sig))
	149	(opt (cadr sig))
	150	(var (caddr sig))
	151	(all (+ req opt var)))
	152	(if (and (not (eqv? snarf-type 'register))
	153	(not (= (length args) all)))
	154	(error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
f4e09330	155	file line function-name (length args) all)))
13482e95 ML	156	(let ((nice-sig
	157	(if (eq? snarf-type 'register)
	158	function-name
	159	(with-output-to-string
	160	(lambda ()
	161	(format #t "~A" function-name)
fd7ec883	162	(let loop-req ((args args) (r 0))
13482e95 ML	163	(if (< r req)
13482e95 ML	164	(begin
fd7ec883 ML	165	(format #t " ~A" (car args))
	166	(loop-req (cdr args) (+ 1 r)))
	167	(let loop-opt ((o 0) (args args) (tail '()))
	168	(if (< o opt)
	169	(begin
	170	(format #t " [~A" (car args))
	171	(loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
	172	(begin
	173	(if (> var 0)
	174	(format #t " . ~A"
	175	(car args)))
	176	(let loop-tail ((tail tail))
	177	(if (not (null? tail))
	178	(begin
	179	(format #t "~A" (car tail))
cecb4a5e NJ	180	(loop-tail (cdr tail))))))))))))))
	181	(scm-deffnx
	182	(if (and manual-flag (eq? snarf-type 'primitive))
	183	(with-output-to-string
	184	(lambda ()
8f85c0c6	185	(format #t "@deffnx {C Function} ~A (" c-function-name)
cecb4a5e	186	(unless (null? args)
8f85c0c6	187	(format #t "~A" (car args))
cecb4a5e NJ	188	(let loop ((args (cdr args)))
cecb4a5e NJ	189	(unless (null? args)
8f85c0c6	190	(format #t ", ~A" (car args))
cecb4a5e NJ	191	(loop (cdr args)))))
	192	(format #t ")\n")))
	193	#f)))
13482e95 ML	194	(format #t "\n\f~A\n" function-name)
13482e95 ML	195	(format #t "@c snarfed from ~A:~A\n" file line)
8f85c0c6	196	(format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
cecb4a5e NJ	197	(let loop ((strings docstring) (scm-deffnx scm-deffnx))
	198	(cond ((null? strings))
	199	((or (not scm-deffnx)
	200	(and (>= (string-length (car strings))
	201	primitive-deffnx-sig-length)
	202	(string=? (substring (car strings)
	203	0 primitive-deffnx-sig-length)
	204	primitive-deffnx-signature)))
	205	(display (car strings))
	206	(loop (cdr strings) scm-deffnx))
	207	(else (display scm-deffnx)
	208	(loop strings #f))))
	209	(display "\n")
cecb4a5e	210	(display "@end deffn\n"))))
13482e95	211
58e17e27 ML	212	(define (texi-quote s)
	213	(let rec ((i 0))
	214	(if (= i (string-length s))
	215	""
	216	(string-append (let ((ss (substring s i (+ i 1))))
	217	(if (string=? ss "@")
	218	"@@"
	219	ss))
	220	(rec (+ i 1))))))
	221
	222	(define (process-multiline-directive l)
	223
	224	(define do-args
	225	(match-lambda
aa3eb769	226
58e17e27 ML	227	(('(paren_close . paren_close))
58e17e27 ML	228	'())
aa3eb769	229
58e17e27 ML	230	(('(comma . comma) rest ...)
58e17e27 ML	231	(do-args rest))
aa3eb769	232
58e17e27 ML	233	(('(id . SCM) ('id . name) rest ...)
	234	(cons name (do-args rest)))
	235
	236	(x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
	237
	238	(define do-arglist
	239	(match-lambda
aa3eb769	240
58e17e27 ML	241	(('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
58e17e27 ML	242	'())
aa3eb769	243
58e17e27 ML	244	(('(paren_open . paren_open) rest ...)
58e17e27 ML	245	(do-args rest))
aa3eb769	246
58e17e27 ML	247	(x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
	248
	249	(define do-command
	250	(match-lambda
aa3eb769	251
cecb4a5e NJ	252	(('cname ('id . name))
	253	(set! c-function-name (texi-quote (symbol->string name))))
	254
a04906d9 MV	255	(('fname ('string . name) ...)
a04906d9 MV	256	(set! function-name (texi-quote (apply string-append name))))
aa3eb769	257
58e17e27 ML	258	(('type ('id . type))
	259	(set! snarf-type type))
	260
	261	(('type ('int . num))
	262	(set! snarf-type num))
	263
	264	(('location ('string . file) ('int . line))
	265	(set! file file)
	266	(set! line line))
	267
	268	(('arglist rest ...)
	269	(set! args (do-arglist rest)))
	270
	271	(('argsig ('int . req) ('int . opt) ('int . var))
	272	(set! sig (list req opt var)))
	273
	274	(x (error (format #f "unknown doc attribute: ~A" x)))))
	275
	276	(define do-directive
	277	(match-lambda
aa3eb769	278
58e17e27 ML	279	((('id . command) rest ...)
58e17e27 ML	280	(do-command (cons command rest)))
aa3eb769	281
58e17e27 ML	282	((('string . string) ...)
58e17e27 ML	283	(set! docstring string))
aa3eb769	284
58e17e27 ML	285	(x (error (format #f "unknown doc attribute syntax: ~A" x)))))
	286
	287	(do-directive l))
	288
	289	(define (process-singleline l)
aa3eb769	290
58e17e27 ML	291	(define do-argpos
	292	(match-lambda
	293	((('id . name) ('int . pos) ('int . line))
	294	(let ((idx (list-index args name)))
	295	(when idx
	296	(unless (= (+ idx 1) pos)
	297	(display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
4d772ae2 ML	298	file line name pos (+ idx 1))
4d772ae2 ML	299	(current-error-port))))))
58e17e27	300	(x #f)))
aa3eb769	301
58e17e27 ML	302	(define do-command
	303	(match-lambda
	304	(('(id . argpos) rest ...)
	305	(do-argpos rest))
	306	(x (error (format #f "unknown check: ~A" x)))))
aa3eb769	307
58e17e27 ML	308	(when function-name
58e17e27 ML	309	(do-command l)))
13482e95 ML	310
13482e95 ML	311	(define main snarf-check-and-output-texi)