home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / documentation.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  7.6 KB  |  214 lines
  1. ;;;;     Copyright (C) 2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc.
  2. ;;;;
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 2.1 of the License, or (at your option) any later version.
  7. ;;;; 
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;;;
  17.  
  18. ;;; Commentary:
  19.  
  20. ;; * This module exports:
  21. ;;
  22. ;; file-commentary      -- a procedure that returns a file's "commentary"
  23. ;;
  24. ;; documentation-files  -- a search-list of files using the Guile
  25. ;;                         Documentation Format Version 2.
  26. ;;
  27. ;; search-documentation-files -- a procedure that takes NAME (a symbol)
  28. ;;                               and searches `documentation-files' for
  29. ;;                               associated documentation.  optional
  30. ;;                               arg FILES is a list of filenames to use
  31. ;;                               instead of `documentation-files'.
  32. ;;
  33. ;; object-documentation -- a procedure that returns its arg's docstring
  34. ;;
  35. ;; * Guile Documentation Format
  36. ;;
  37. ;; Here is the complete and authoritative documentation for the Guile
  38. ;; Documentation Format Version 2:
  39. ;;
  40. ;; HEADER
  41. ;; ^LPROC1
  42. ;; DOCUMENTATION1
  43. ;;
  44. ;; ^LPROC2
  45. ;; DOCUMENTATION2
  46. ;;
  47. ;; ^L...
  48. ;;
  49. ;; The HEADER is completely ignored.  The "^L" are formfeeds.  PROC1, PROC2
  50. ;; and so on are symbols that name the element documented.  DOCUMENTATION1,
  51. ;; DOCUMENTATION2 and so on are the related documentation, w/o any further
  52. ;; formatting.  Note that there are two newlines before the next formfeed;
  53. ;; these are discarded when the documentation is read in.
  54. ;;
  55. ;; (Version 1, corresponding to guile-1.4 and prior, is documented as being
  56. ;; not documented anywhere except by this embarrassingly circular comment.)
  57. ;;
  58. ;; * File Commentary
  59. ;;
  60. ;; A file's commentary is the body of text found between comments
  61. ;;     ;;; Commentary:
  62. ;; and
  63. ;;     ;;; Code:
  64. ;; both of which must be at the beginning of the line.  In the result string,
  65. ;; semicolons at the beginning of each line are discarded.
  66. ;;
  67. ;; You can specify to `file-commentary' alternate begin and end strings, and
  68. ;; scrub procedure.  Use #t to get default values.  For example:
  69. ;;
  70. ;; (file-commentary "documentation.scm")
  71. ;; You should see this text!
  72. ;;
  73. ;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$")
  74. ;; You should see the rest of this file.
  75. ;;
  76. ;; (file-commentary "documentation.scm" #t #t string-upcase)
  77. ;; You should see this text very loudly (note semicolons untouched).
  78.  
  79. ;;; Code:
  80.  
  81. (define-module (ice-9 documentation)
  82.   :use-module (ice-9 rdelim)
  83.   :export (file-commentary
  84.            documentation-files search-documentation-files
  85.            object-documentation)
  86.   :autoload (ice-9 regex) (match:suffix)
  87.   :no-backtrace)
  88.  
  89.  
  90. ;;
  91. ;; commentary extraction
  92. ;;
  93.  
  94. (define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB)
  95.    
  96.   ;; These are constants but are not at the top level because the repl in
  97.   ;; boot-9.scm loads session.scm which in turn loads this file, and we want
  98.   ;; that to work even even when regexps are not available (ie. make-regexp
  99.   ;; doesn't exist), as for instance is the case on mingw.
  100.   ;;
  101.   (define default-in-line-re (make-regexp "^;;; Commentary:"))
  102.   (define default-after-line-re (make-regexp "^;;; Code:"))
  103.   (define default-scrub (let ((dirt (make-regexp "^;+")))
  104.               (lambda (line)
  105.                 (let ((m (regexp-exec dirt line)))
  106.                   (if m (match:suffix m) line)))))
  107.        
  108.   ;; fixme: might be cleaner to use optargs here...
  109.   (let ((in-line-re (if (> 1 (length cust))
  110.                         default-in-line-re
  111.                         (let ((v (car cust)))
  112.                           (cond ((regexp? v) v)
  113.                                 ((string? v) (make-regexp v))
  114.                                 (else default-in-line-re)))))
  115.         (after-line-re (if (> 2 (length cust))
  116.                            default-after-line-re
  117.                            (let ((v (cadr cust)))
  118.                              (cond ((regexp? v) v)
  119.                                    ((string? v) (make-regexp v))
  120.                                    (else default-after-line-re)))))
  121.         (scrub (if (> 3 (length cust))
  122.                    default-scrub
  123.                    (let ((v (caddr cust)))
  124.                      (cond ((procedure? v) v)
  125.                            (else default-scrub))))))
  126.     (call-with-input-file filename
  127.       (lambda (port)
  128.     (let loop ((line (read-delimited "\n" port))
  129.            (doc "")
  130.            (parse-state 'before))
  131.       (if (or (eof-object? line) (eq? 'after parse-state))
  132.           doc
  133.           (let ((new-state
  134.              (cond ((regexp-exec in-line-re line) 'in)
  135.                ((regexp-exec after-line-re line) 'after)
  136.                (else parse-state))))
  137.         (if (eq? 'after new-state)
  138.             doc
  139.             (loop (read-delimited "\n" port)
  140.               (if (and (eq? 'in new-state) (eq? 'in parse-state))
  141.                   (string-append doc (scrub line) "\n")
  142.                   doc)
  143.               new-state)))))))))
  144.  
  145.  
  146.  
  147. ;;
  148. ;; documentation-files is the list of places to look for documentation
  149. ;;
  150. (define documentation-files
  151.   (map (lambda (vicinity)
  152.      (in-vicinity (vicinity) "guile-procedures.txt"))
  153.        (list %library-dir
  154.          %package-data-dir
  155.          %site-dir
  156.          (lambda () "."))))
  157.  
  158. (define entry-delimiter "\f")
  159.  
  160. (define (find-documentation-in-file name file)
  161.   (and (file-exists? file)
  162.        (call-with-input-file file
  163.      (lambda (port)
  164.        (let ((name (symbol->string name)))
  165.          (let ((len (string-length name)))
  166.            (read-delimited entry-delimiter port) ;skip to first entry
  167.            (let loop ((entry (read-delimited entry-delimiter port)))
  168.          (cond ((eof-object? entry) #f)
  169.                ;; match?
  170.                ((and ;; large enough?
  171.                  (>= (string-length entry) len)
  172.              ;; matching name?
  173.              (string=? (substring entry 0 len) name)
  174.              ;; terminated?
  175.              (memq (string-ref entry len) '(#\newline)))
  176.             ;; cut away name tag and extra surrounding newlines
  177.             (substring entry (+ len 2) (- (string-length entry) 2)))
  178.                (else (loop (read-delimited entry-delimiter port)))))))))))
  179.  
  180. (define (search-documentation-files name . files)
  181.   (or-map (lambda (file)
  182.         (find-documentation-in-file name file))
  183.           (cond ((null? files) documentation-files)
  184.                 (else files))))
  185.  
  186. ;; helper until the procedure documentation property is cleaned up
  187. (define (proc-doc proc)
  188.   (or (procedure-documentation proc)
  189.       (procedure-property proc 'documentation)))
  190.  
  191. (define (object-documentation object)
  192.   "Return the docstring for OBJECT.
  193. OBJECT can be a procedure, macro or any object that has its
  194. `documentation' property set."
  195.   (or (and (procedure? object)
  196.        (proc-doc object))
  197.       (and (defmacro? object)
  198.        (proc-doc (defmacro-transformer object)))
  199.       (and (macro? object)
  200.        (let ((transformer (macro-transformer object)))
  201.          (and transformer
  202.           (proc-doc transformer))))
  203.       (object-property object 'documentation)
  204.       (and (procedure? object)
  205.        (not (closure? object))
  206.        (procedure-name object)
  207.        (let ((docstring (search-documentation-files
  208.                              (procedure-name object))))
  209.          (if docstring
  210.          (set-procedure-property! object 'documentation docstring))
  211.          docstring))))
  212.  
  213. ;;; documentation.scm ends here
  214.