;;; c-snarf.scm  --  Parsing documentation "snarffed" from C files.
;;;
;;; Copyright 2006-2012 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 3 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., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA

(define-module (system documentation c-snarf)
  :use-module (ice-9 popen)
  :use-module (ice-9 rdelim)

  :use-module (srfi srfi-13)
  :use-module (srfi srfi-14)
  :use-module (srfi srfi-39)

  :export (run-cpp-and-extract-snarfing
           parse-snarfing
           parse-snarfed-line))

;;; Author:  Ludovic Courtès
;;;
;;; Commentary:
;;;
;;; This module provides tools to parse and otherwise manipulate
;;; documentation "snarffed" from C files, i.e., information obtained by
;;; running the C preprocessor with the @code{-DSCM_MAGIC_SNARF_DOCS} flag.
;;;
;;; Code:



;;;
;;; High-level API.
;;;

(define (run-cpp-and-extract-snarfing file cpp cpp-flags)
  (let ((pipe (apply open-pipe* OPEN_READ
                     (cons cpp (append cpp-flags (list file))))))
    (parse-snarfing pipe)))


;;;
;;; Parsing magic-snarffed CPP output.
;;;

(define (parse-c-argument-list arg-string)
  "Parse @var{arg-string} (a string representing a ANSI C argument list,
e.g., @var{(const SCM first, SCM second_arg)}) and return a list of strings
denoting the argument names."
  (define %c-symbol-char-set
    (char-set-adjoin char-set:letter+digit #\_))

  (let loop ((args (string-tokenize (string-trim-both arg-string #\space)
				    %c-symbol-char-set))
	     (type? #t)
	     (result '()))
    (if (null? args)
	(reverse! result)
	(let ((the-arg (car args)))
	  (cond ((and type? (string=? the-arg "const"))
		 (loop (cdr args) type? result))
		((and type? (string=? the-arg "SCM"))
		 (loop (cdr args) (not type?) result))
                (type? ;; any other type, e.g., `void'
                 (loop (cdr args) (not type?) result))
		(else
		 (loop (cdr args) (not type?) (cons the-arg result))))))))

(define (parse-documentation-item item)
  "Parse @var{item} (a string), a single function string produced by the C
preprocessor.  The result is an alist whose keys represent specific aspects
of a procedure's documentation: @code{c-name}, @code{scheme-name},
 @code{documentation} (a Texinfo documentation string), etc."

  (define (read-strings)
    ;; Read several subsequent strings and return their concatenation.
    (let loop ((str (read))
               (result '()))
      (if (or (eof-object? str)
              (not (string? str)))
          (string-concatenate (reverse! result))
          (loop (read) (cons str result)))))

  (let* ((item (string-trim-both item #\space))
	 (space (string-index item #\space)))
    (if (not space)
	(error "invalid documentation item" item)
	(let ((kind (substring item 0 space))
	      (rest (substring item space (string-length item))))
	  (cond ((string=? kind "cname")
		 (cons 'c-name (string-trim-both rest #\space)))
		((string=? kind "fname")
		 (cons 'scheme-name
                       (with-input-from-string rest read-strings)))
		((string=? kind "type")
		 (cons 'type (with-input-from-string rest read)))
		((string=? kind "location")
		 (cons 'location
		       (with-input-from-string rest
			 (lambda ()
			   (let loop ((str (read))
				      (result '()))
			     (if (eof-object? str)
				 (reverse! result)
				 (loop (read) (cons str result))))))))
		((string=? kind "arglist")
		 (cons 'arguments
		       (parse-c-argument-list rest)))
		((string=? kind "argsig")
		 (cons 'signature
		       (with-input-from-string rest
			 (lambda ()
			   (let ((req (read)) (opt (read)) (rst? (read)))
			     (list (cons 'required req)
				   (cons 'optional opt)
				   (cons 'rest?    (= 1 rst?))))))))
		(else
		 ;; docstring (may consist of several C strings which we
		 ;; assume to be equivalent to Scheme strings)
		 (cons 'documentation
		       (with-input-from-string item read-strings))))))))

(define (parse-snarfed-line line)
  "Parse @var{line}, a string that contains documentation returned for a
single function by the C preprocessor with the @code{-DSCM_MAGIC_SNARF_DOCS}
option.  @var{line} is assumed to be a complete \"^^ { ... ^^ }\" sequence."
  (define (caret-split str)
    (let loop ((str str)
	       (result '()))
      (if (string=? str "")
	  (reverse! result)
	  (let ((caret (string-index str #\^))
		(len (string-length str)))
	    (if caret
		(if (and (> (- len caret) 0)
			 (eq? (string-ref str (+ caret 1)) #\^))
		    (loop (substring str (+ 2 caret) len)
			  (cons (string-take str (- caret 1)) result))
		    (error "single caret not allowed" str))
		(loop "" (cons str result)))))))

  (let ((items (caret-split (substring line 4
				       (- (string-length line) 4)))))
    (map parse-documentation-item items)))


(define (parse-snarfing port)
  "Read C preprocessor (where the @code{SCM_MAGIC_SNARF_DOCS} macro is
defined) output from @var{port} a return a list of alist, each of which
contains information about a specific function described in the C
preprocessor output."
  (define start-marker "^^ {")
  (define end-marker   "^^ }")

  (define (read-snarf-lines start)
    ;; Read the snarf lines that follow START until and end marker is found.
    (let loop ((line   start)
               (result '()))
      (cond ((eof-object? line)
             ;; EOF in the middle of a "^^ { ... ^^ }" sequence; shouldn't
             ;; happen.
             line)
            ((string-contains line end-marker)
             =>
             (lambda (end)
               (let ((result (cons (string-take line (+ 3 end))
                                   result)))
                 (string-concatenate-reverse result))))
            ((string-prefix? "#" line)
             ;; Presumably a "# LINENUM" directive; skip it.
             (loop (read-line port) result))
            (else
             (loop (read-line port)
                   (cons line result))))))

  (let loop ((line (read-line port))
	     (result '()))
    (cond ((eof-object? line)
           result)
          ((string-contains line start-marker)
           =>
           (lambda (start)
             (let ((line
                    (read-snarf-lines (string-drop line start))))
               (loop (read-line port)
                     (cons (parse-snarfed-line line) result)))))
          (else
           (loop (read-line port) result)))))


;;; c-snarf.scm ends here

;;; Local Variables:
;;; mode: scheme
;;; coding: latin-1
;;; End:

;;; arch-tag: dcba2446-ee43-46d8-a47e-e6e12f121988