1. Paul Sexton
  2. clod

Commits

Paul Sexton  committed 5fe1fb3

Alphabetic index.
Function SAFE-SYMBOL escapes any formatting characters in symbols.
Write preamble at beginning of file, with useful org-mode options.
Each type of entity (Functions, Macros etc) now has its own Section.

  • Participants
  • Parent commits 3a5b1b6
  • Branches default

Comments (0)

Files changed (1)

File clod.lisp

View file
 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;;;;;;;;;;;;;;80
 
+;; still unclear how to tell if a symbol is bound to a type.
+;; eg (deftype =foo= () `(integer 0 10))
+;;
+;; todo would be nice to get CL symbols to link to hyperspec
+;;    (if (eql (symbol-package sym) (find-package :cl)) ...)
+;; Currently [[hs:sym]]  --> HyperSpecRoot/sym but this will not work as
+;; hyperspec pages are unfortunately not named according to the symbol they
+;; describe.
+;;
+;; todo table of slots at beginning of each class def
+;;
+;; todo use to document self
+;;
+;; todo need to escape org format chars in symbols: *, / etc
+;; deploy SAFE-SYMBOL
+;;
+;; todo distinguish structs more.
+
 (in-package :cl-user)
 
 (declaim (optimize (speed 0) (safety 3) (debug 3)))
   "* Description
 Number of spaces to which text is currently being indented.")
 (defvar *ambiguities* nil)
+(defconstant +alphabet+
+  (loop for i from 1 to 26 collecting (code-char (+ 64 i)))
+  "List of uppercase letters (characters) from A to Z.")
 
 (deftype =entity= ()
   "* Description
 Write a section documenting the entity named SYM which is of entity type
 DOCTYPE."))
 
-;; still unclear how to tell if a symbol is bound to a type.
-;; eg (deftype =foo= () `(integer 0 10))
-
-;; todo would be nice to get CL symbols to link to hyperspec
-;;    (if (eql (symbol-package sym) (find-package :cl)) ...)
-;; todo table of slots at beginning of each class def
-;; todo use to document self
-;; todo need to escape org format chars in symbols: *, / etc
 
 ;;;; Utility functions ========================================================
 
                    (mapcar #'slot-definition-writers slots)))))
 
 
+(defun uses-for-symbol (sym)
+  (let ((uses nil))
+    (when (find-package sym)
+      (push :package uses))
+    (when (find-class sym nil)
+      (push :class uses))
+    (cond
+      ((macro-function sym)
+       (push :macro uses))
+      ((and (fboundp sym)
+            (typep (fboundp sym) (find-class 'generic-function)))
+       (push :generic-function uses))
+      ((fboundp sym)
+       (push :function uses)))
+    (cond
+      ((and (boundp sym)
+            (constantp sym))
+       (push :constant uses))
+      ((boundp sym)
+       (push :variable uses)))
+    uses))
+
+
+
 (defun word-wrap (text &key (width 80) respect-newlines respect-hyphens
 		  exclude-start-char exclude-end-char)
   "* Arguments
     (finally (return (list text)))))
 
 
+(defparameter *unsafe-symbol-strings*
+  ;; These SEEM to only be interpreted as formatting directives when they occur
+  ;; at the beginning of words. Hence the ^ at the beginning of each regex.
+  '(("^\\*" . "\\*")  ;; bold
+    ("^/" . "\\/")    ;; italic
+    ("^\\+" . "\\+")  ;; strikethrough
+    ("^_" . "\\_")    ;; underline
+    ("^=" . "\\="))   ;; code
+  "Alist of (REGEX . REPLACEMENT). Used to ensure that symbols do not
+contain any characters which org will misinterpret as formatting directives.")
+
+
+(defun safe-symbol (sym)
+  (unless (stringp sym)
+    (setf sym (format nil "~A" sym)))
+  (iterate
+    (for (regex . replacement) in *unsafe-symbol-strings*)
+    (setf sym (regex-replace-all regex sym replacement)))
+  sym)
+
+  
 ;;;; Formatting  ==============================================================
 
 
+(defun write-preamble (&key (title "Documentation"))
+  (write-out "~&#+TITLE: ~A" title)
+  (write-out "~&#+LINK: hs ~A/%s" (if (eql 0 (search "http:" *hyperspec-root*))
+                                      *hyperspec-root*
+                                      (format nil "file:~A" *hyperspec-root*)))
+  (write-out "~&#+OPTIONS: toc:3 H:10~%~%"))
+
+
+
 (defun write-docstring (str &key (levels *heading-level*)
                         (default "Not documented."))
   (cond
   (apply #'format *out* (concatenate 'string "~&- " fmt "~&") args))
 
 
+(defun write-index (pkg &optional (accessibility :external))
+  (let ((symbols nil)
+        (index-table (make-hash-table :test 'eql)))
+    (do-own-symbols (sym pkg)
+      (when (and (eql (symbol-accessibility sym pkg) accessibility)
+                 (uses-for-symbol sym))
+        (push sym symbols)))
+    (setf symbols (sort symbols #'string>))
+    (dolist (sym symbols)
+      (push sym (gethash (if (alpha-char-p (elt (string sym) 0))
+                             (elt (string sym) 0)
+                             'nonalphabetic)
+                         index-table)))
+    (writing-section ("Index")
+      (dolist (line
+                (word-wrap
+                 (format nil
+                         "~%~{~A  ~}~%"
+                         (iterate
+                           (for (ch nil) in-hashtable index-table)
+                           (collect (format nil "[[index ~A][~A]]" ch ch))))
+                 :width *line-width*))
+        (write-out line))
+      (iterate
+        (for ch in (cons 'nonalphabetic +alphabet+))
+        (for syms = (gethash ch index-table))
+        (when syms
+          (writing-section ((format nil "~A" ch))
+            (write-out "~%# link target: <<index ~A>>~%" ch)
+            (writing-bulleted-list
+              (iterate
+                (for sym in syms)
+                (iterate
+                  (for use in (uses-for-symbol sym))
+                  (write-bullet-point
+                   "~A, ~:(~A~)"
+                   (make-link (string sym) :linktype use)
+                   (entity->string use)))))))))))
+
+
+
+(defun write-disambiguation (sym uses)
+  (writing-section (sym)
+    (write-out "# target: ~A~%" (make-target (string sym)))
+    (write-out "Disambiguation.~%~%")
+    (writing-bulleted-list
+      (iterate
+        (for use in uses)
+        (write-bullet-point "~:(~A~): ~A" (entity->string use)
+                            (string-downcase
+                             (make-link (string sym) :linktype use)))))))
+
+
+
+;;;; Document methods =========================================================
+
+
 
 (defmethod document :after ((sym symbol) (doctype t))
   (terpri *out*))
           (document fname 'slot-writer))))))
 
 
+
 ;;;; Toplevel =================================================================
 
 
+(defmacro do-own-symbols ((var pkg) &body body)
+  `(let ((%shadow-symbols (package-shadowing-symbols ,pkg)))
+     (do-symbols (,var ,pkg)
+       (unless (find ,var %shadow-symbols)
+         ,@body))))
+
+
 (defun document-package-contents (pkg &optional (accessibility :external))
   (let ((access nil) (uses nil)
         (functions nil)
     (unless (packagep pkg)
       (setf pkg (find-package pkg)))
     (setf *ambiguities* (make-hash-table :test #'eql))
-    (do-symbols (sym pkg)
-      (setf uses nil)
+    (do-own-symbols (sym pkg)
       (setf access (symbol-accessibility sym pkg))
-      (when (and (not (find sym (package-shadowing-symbols pkg)))
-                 (eql accessibility access))
-        (when (find-class sym nil)
-          (push sym classes)
-          (push :class uses))
-        (cond
-          ((macro-function sym)
-           (push sym macros)
-           (push :macro uses))
-          ((and (fboundp sym)
-                (typep (fboundp sym) (find-class 'generic-function)))
-           (push sym generics)
-           (push :generic-function uses))
-          ((fboundp sym)
-           (push sym functions)
-           (push :function uses)))
-        (cond
-          ((and (boundp sym)
-                (constantp sym))
-           (push sym constants)
-           (push :constant uses))
-          ((boundp sym)
-           (push sym vars)
-           (push :variable uses)))
+      (when (eql accessibility access)
+        (setf uses (uses-for-symbol sym))
+        (if (find :class uses) (push sym classes))
+        (if (find :macro uses) (push sym macros))
+        (if (find :generic-function uses) (push sym generics))
+        (if (find :function uses) (push sym functions))
+        (if (find :constant uses) (push sym constants))
+        (if (find :variable uses) (push sym vars))
         (if (> (length uses) 1)
             (setf (gethash sym *ambiguities*) (copy-list uses)))))
     ;; Remove any generic functions that represent slot accessors
           (set-difference generics
                           (list-all-slot-accessors
                            (mapcar #'find-class classes))))
+    ;; === main body of definitions ===
+    (writing-section ("Functions")
     (dolist (sym functions)
-      (document sym 'function))
+      (document sym 'function)))
+    (writing-section ("Macros")
     (dolist (sym macros)
-      (document sym 'macro))
+      (document sym 'macro)))
+    (writing-section ("Generic Functions")
     (dolist (sym generics)
-      (document sym 'generic))
+      (document sym 'generic)))
+    (writing-section ("Classes")
     (dolist (sym classes)
-      (document sym 'class))
+      (document sym 'class)))
+    (writing-section ("Global Variables")
     (dolist (sym vars)
-      (document sym 'var))
+      (document sym 'var)))
+    (writing-section ("Constants")
     (dolist (sym constants)
-      (document sym 'constant))
-    (iterate
-      (for (sym uses) in-hashtable *ambiguities*)
-      (writing-section (sym)
-        (write-out "# target: ~A~%" (make-target (string sym)))
-        (write-out "Disambiguation.~%~%")
-        (writing-bulleted-list
-          (iterate
-            (for use in uses)
-            (write-bullet-point "~:(~A~): ~A" (entity->string use)
-                                (string-downcase
-                                 (make-link (string sym) :linktype use)))))))))
+      (document sym 'constant)))
+    (when (plusp (hash-table-count *ambiguities*))
+      (writing-section ("Ambiguous Symbols")
+        (iterate
+          (for (sym uses) in-hashtable *ambiguities*)
+          (write-disambiguation sym uses))))
+    ;; === index ===
+    (write-index pkg accessibility)))
+
 
 
 (defun docpkg (&rest pkgnames)
-    ;; todo documentation for the package
-    ;; todo document multiple packages in one file?
-    (dolist (pkg (mapcar #'find-package pkgnames))
-      (writing-section (:package (package-name pkg))
-        (writing-bulleted-list
-          (write-bullet-point "Uses:")
-          (write-indented (4)
-            (write-list-as-paragraph
-             (mapcar #'make-package-link
-                     (mapcar #'string-downcase
-                     (mapcar #'package-name (package-use-list pkg))))))
-          (write-bullet-point "Used by:")
-          (write-indented (4)
-            (cond
-              ((package-used-by-list pkg)
-               (write-list-as-paragraph
-                (mapcar #'make-package-link
-                        (mapcar #'string-downcase
-                                (mapcar #'package-name (package-used-by-list pkg))))))
-              (t
-               (write-out "None.")))))
-        (write-docstring-section "Description" (documentation pkg t))
-        (document-package-contents pkg :external)
-        (document-package-contents pkg :internal))))
+  ;; todo documentation for the package
+  ;; todo document multiple packages in one file?
+  (write-preamble)
+  (dolist (pkg (mapcar #'find-package pkgnames))
+    (writing-section (:package (package-name pkg))
+      (writing-bulleted-list
+        (write-bullet-point "Uses:")
+        (write-indented (4)
+          (write-list-as-paragraph
+           (mapcar #'make-package-link
+                   (mapcar #'string-downcase
+                           (mapcar #'package-name (package-use-list pkg))))))
+        (write-bullet-point "Used by:")
+        (write-indented (4)
+          (cond
+            ((package-used-by-list pkg)
+             (write-list-as-paragraph
+              (mapcar #'make-package-link
+                      (mapcar #'string-downcase
+                              (mapcar #'package-name (package-used-by-list pkg))))))
+            (t
+             (write-out "None.")))))
+      (write-docstring-section "Description" (documentation pkg t))
+      (document-package-contents pkg :external)
+      (document-package-contents pkg :internal))))
 
 
 (defun docpkg-file (filename &rest pkgnames)
     (apply #'docpkg pkgnames)))
 
 
-;;;; Test package =============================================================
-
-(defpackage :mypkg
-  (:use :cl :closer-mop)
-  (:shadowing-import-from :closer-mop
-                          #:standard-method
-                          #:standard-generic-function
-                          #:defmethod
-                          #:defgeneric
-                          #:standard-class))
-(in-package :mypkg)
-(defvar *foovar* 3 "A variable.")
-(defconstant +fooconst+ 44 "A constant.")
-(defun foofun (x y)
-  "A function."
-  (+ x y))
-(defvar foofun #\x)
-(defclass <foo> ()
-  ((fooslot :initform 0 :accessor fooslot))
-  (:documentation "A class."))
-(defclass <foochild> (<foo>)
-  ((childslot :initform 1 :accessor childslot
-              :documentation "Child slot doc"))
-  (:documentation "A child class."))
-(defgeneric foomethod (a b)
-  (:documentation "A generic function."))
-(defmethod foomethod ((a integer) (b integer))
-  (- a b))
-(defmethod barmethod ((a integer) b &key (c nil))
-  (+ a b))
-(defmacro foomac (x)
-  "A macro."
-  `(+ ,x))
-(defstruct foostruct
-  "A structure."
-  x y)
-(make-instance '<foo>)
-(in-package :clod)
-