src/cl-info.lisp

   1 (in-package :cl-info)
   2
   3 (defvar *info-tables* (make-hash-table :test 'equal))
   4
   5 ;; Gcl doesn't like equalp hashtables.
   6 (defvar *html-index*
   7   (make-hash-table :test #-gcl #'equalp #+gcl #'equal)
   8   "Hash table for looking up which html file contains the
   9   documentation.  The key is the topic we're looking for and the value
  10   is a cons consisting of the html file and the id for the key.")
  11
  12
  13 (defun print-prompt (prompt-count)
  14   (fresh-line)
  15   (maxima::format-prompt
  16    t "~a"
  17    (if (zerop prompt-count)
  18               (intl:gettext "Enter space-separated numbers, `all' or `none': ")
  19               (intl:gettext "Still waiting: "))))
  20
  21 (defvar +select-by-keyword-alist+
  22   '((noop "") (all "a" "al" "all") (none "n" "no" "non" "none")))
  23
  24 (defun parse-user-choice (nitems)
  25   (loop
  26    with line = (read-line #+(or sbcl cmu) *standard-input*) and nth and pos = 0
  27    while (multiple-value-setq (nth pos)
  28            (parse-integer line :start pos :junk-allowed t))
  29    if (or (minusp nth) (>= nth nitems))
  30    do (format *debug-io* (intl:gettext "~&Discarding invalid number ~d.") nth)
  31    else collect nth into list
  32    finally
  33    (let ((keyword
  34           (car (rassoc
  35                 (string-right-trim
  36                  '(#\space #\tab #\newline #\;) (subseq line pos))
  37                 +select-by-keyword-alist+
  38                 :test #'(lambda (item list)
  39                           (member item list :test #'string-equal))))))
  40      (unless keyword
  41        (setq keyword 'noop)
  42        (format *debug-io* (intl:gettext "~&Ignoring trailing garbage in input.")))
  43      (return (cons keyword list)))))
  44
  45 (defun select-info-items (selection items)
  46   (case (pop selection)
  47     (noop (loop
  48            for i in selection
  49            collect (nth i items)))
  50     (all items)
  51     (none 'none)))
  52
  53 ; ------------------------------------------------------------------
  54 ; STUFF ABOVE SALVAGED FROM PREVIOUS INCARNATION OF SRC/CL-INFO.LISP
  55 ; STUFF BELOW IS NEW, BASED ON LOOKUP TABLE BUILT AHEAD OF TIME
  56 ; ------------------------------------------------------------------
  57
  58 ; ------------------ search help topics ------------------
  59
  60 (defun maxima::combine-path (&rest list)
  61   "splice a '/' between the path components given as arguments"
  62   (format nil "~{~A~^/~}" list))
  63
  64 (defun load-primary-index ()
  65   (declare (special maxima::*maxima-lang-subdir* maxima::*maxima-infodir*))
  66   ;; Is with-standard-io-syntax too much for what we want?
  67   (let*
  68       ((subdir-bit (or maxima::*maxima-lang-subdir* "."))
  69        (path-to-index (maxima::combine-path maxima::*maxima-infodir* subdir-bit "maxima-index.lisp"))
  70        (path-to-html-index
  71          (maxima::combine-path maxima::*maxima-infodir* subdir-bit "maxima-index-html.lisp")))
  72     ;; Set the default of the html URL base to be a file URL pointing
  73     ;; to the info dir.
  74     (setf maxima::$url_base (concatenate 'string
  75                              "file://"
  76                              (if maxima::*maxima-lang-subdir*
  77                                  (maxima::combine-path maxima::*maxima-htmldir*
  78                                                        maxima::*maxima-lang-subdir*)
  79                                  maxima::*maxima-htmldir*)))
  80
  81     (handler-case
  82       (with-standard-io-syntax (load path-to-index))
  83       (error (condition) (warn (intl:gettext (format nil "~&Maxima is unable to set up the help system.~&(Details: CL-INFO::LOAD-PRIMARY-INDEX: ~a)~&" condition)))))
  84     (handler-case
  85         (with-standard-io-syntax (load path-to-html-index))
  86       (error (condition) (warn (intl:gettext (format nil "~&Maxima is unable to set up the help system.~&(Details: CL-INFO::LOAD-PRIMARY-INDEX: ~a)~&" condition)))))))
  87
  88
  89 (defun info-exact (x)
  90   (let ((exact-matches (exact-topic-match x)))
  91     (if (not (some-exact x exact-matches))
  92       (progn
  93         (format t (intl:gettext "  No exact match found for topic `~a'.~%  Try `?? ~a' (inexact match) instead.~%~%") x x)
  94         nil)
  95       (progn
  96         (display-items exact-matches)
  97         (if (some-inexact x (inexact-topic-match x))
  98           (format t (intl:gettext "  There are also some inexact matches for `~a'.~%  Try `?? ~a' to see them.~%~%") x x))
  99         t))))
 100
 101 (defun some-exact (x matches)
 102   (some #'identity (flatten-matches x matches)))
 103
 104 (defun some-inexact (x matches)
 105   (some #'null (flatten-matches x matches)))
 106
 107 (defun flatten-matches (x matches)
 108   ;; OH GODS, SPARE YOUR SERVANT FROM YOUR FIERY WRATH ...
 109   (mapcar #'(lambda (y) (equal y x)) (mapcar #'first (apply #'append (mapcar #'second matches)))))
 110
 111 (defun exact-topic-match (topic)
 112   (setq topic (regex-sanitize topic))
 113   (loop for dir-name being the hash-keys of *info-tables*
 114     collect (list dir-name (exact-topic-match-1 topic dir-name))))
 115
 116 (defun exact-topic-match-1 (topic d)
 117   (let*
 118     ((section-table (first (gethash d *info-tables*)))
 119      (defn-table (second (gethash d *info-tables*)))
 120      (regex1 (concatenate 'string "^" topic "$"))
 121      (regex2 (concatenate 'string "^" topic " *<[0-9]+>$")))
 122     (append
 123       (find-regex-matches regex1 section-table)
 124       (find-regex-matches regex1 defn-table)
 125       (find-regex-matches regex2 section-table)
 126       (find-regex-matches regex2 defn-table))))
 127
 128 (defun info-inexact (x)
 129   (let ((inexact-matches (inexact-topic-match x)))
 130     (when inexact-matches
 131       (display-items inexact-matches))
 132     (not (null inexact-matches))))
 133
 134 ;; MATCHES looks like ((D1 (I11 I12 I12 ...)) (D2 (I21 I22 I23 ...)))
 135 ;; Rearrange it to ((D1 I11) (D1 I12) (D1 I13) ... (D2 I21) (D2 I22) (D2 I23) ...)
 136 (defun rearrange-matches (matches)
 137   (apply #'append (mapcar #'(lambda (di) (let ((d (first di)) (i (second di))) (mapcar #'(lambda (i1) (list d i1)) i))) matches)))
 138
 139 (defun display-items (items)
 140   (let*
 141     ((items-list (rearrange-matches items))
 142      (nitems (length items-list))
 143      wanted)
 144
 145     (loop for i from 0 for item in items-list do
 146       (when (> nitems 1)
 147         (let
 148           ((heading-title (nth 4 (second item)))
 149            (item-name (first (second item))))
 150           (format t "~% ~d: ~a~@[  (~a)~]" i item-name heading-title))))
 151
 152     (setq wanted
 153           (if (> nitems 1)
 154             (prog1
 155               (loop
 156                 for prompt-count from 0
 157                 thereis (progn
 158                           (finish-output *debug-io*)
 159                           (print-prompt prompt-count)
 160                           (finish-output)
 161                           #-(or sbcl cmu) (clear-input)
 162                           (select-info-items
 163                             (parse-user-choice nitems) items-list)))
 164               #-(or sbcl cmu) (clear-input))
 165             items-list))
 166     (finish-output *debug-io*)
 167     (when (consp wanted)
 168       (format t "~%")
 169       (funcall maxima::*help-display-function* wanted)
 170       #+nil
 171       (cond
 172         (maxima::$describe_uses_html
 173          (when maxima::*debug-display-html-help*
 174            (format *debug-io* "wanted = ~A~%" wanted))
 175          (loop for (dir entry) in wanted
 176                do (maxima::display-html-help (car entry))))
 177         (t
 178           (loop for item in wanted
 179                 do (let ((doc (read-info-text (first item) (second item))))
 180                      (if doc
 181                          (format t "~A~%~%" doc)
 182                          (format t "Unable to find documentation for `~A'.~%~
 183                                 Possible bug maxima-index.lisp or build_index.pl?~%"
 184                                  (first (second item)))))))))))
 185
 186 (defun inexact-topic-match (topic)
 187   (setq topic (regex-sanitize topic))
 188   (let ((foo (loop for dir-name being the hash-keys of *info-tables*
 189     collect (list dir-name (inexact-topic-match-1 topic dir-name)))))
 190     (remove-if #'(lambda (x) (null (second x))) foo)))
 191
 192 (defun inexact-topic-match-1 (topic d)
 193   (let*
 194     ((section-table (first (gethash d *info-tables*)))
 195      (defn-table (second (gethash d *info-tables*))))
 196     (append
 197       (find-regex-matches topic section-table)
 198       (find-regex-matches topic defn-table))))
 199
 200 (defun regex-sanitize (s)
 201   "Precede any regex special characters with a backslash."
 202   (pregexp:pregexp-quote s))
 203
 204 (defun find-regex-matches (regex-string hashtable)
 205   (let*
 206       ;; Do the search ignoring case by wrapping the regex-string in
 207       ;; "(?i:...)"
 208       ((regex (concatenate 'string "(?i:" regex-string ")"))
 209        (regex-matches nil))
 210     (maphash
 211      #'(lambda (key value)
 212          (when (pregexp:pregexp-match-positions regex key)
 213            #+nil
 214            (format t "key value: ~S ~S: match ~A~%"
 215                    key value (pregexp:pregexp-match-positiions regex key))
 216            (setq regex-matches (cons `(,key . ,value) regex-matches))))
 217       hashtable)
 218     (stable-sort regex-matches #'string-lessp :key #'car)))
 219
 220 (defun read-info-text (dir-name parameters)
 221   (let*
 222     ((value (cdr parameters))
 223      (filename (car value))
 224      (byte-offset (cadr value))
 225      (char-count (caddr value))
 226      (text (make-string char-count))
 227      (path+filename (merge-pathnames (make-pathname :name filename) dir-name)))
 228     (handler-case
 229         (with-open-file (in path+filename :direction :input)
 230           (unless (plusp byte-offset)
 231             ;; If byte-offset isn't positive there must be some error in
 232             ;; the index.  Return nil and let the caller deal with it.
 233             (return-from read-info-text nil))
 234           (file-position in byte-offset)
 235           (read-sequence text in :start 0 :end char-count)
 236           text)
 237       (error () (maxima::merror "Cannot find documentation for `~M': missing info file ~M~%"
 238                                 (car parameters) (namestring path+filename))))))
 239
 240 ; --------------- build help topic indices ---------------
 241
 242 (defun load-info-hashtables (dir-name deffn-defvr-pairs section-pairs)
 243   (if (and (zerop (length section-pairs))
 244            (zerop (length deffn-defvr-pairs)))
 245     (format t (intl:gettext "warning: ignoring an empty documentation index in ~a~%") dir-name)
 246     (destructuring-bind
 247       (section-hashtable deffn-defvr-hashtable)
 248       (ensure-info-tables dir-name)
 249       (mapc #'(lambda (x) (setf (gethash (car x) section-hashtable) (cdr x))) section-pairs)
 250       (mapc #'(lambda (x) (setf (gethash (car x) deffn-defvr-hashtable) (cdr x))) deffn-defvr-pairs))))
 251
 252 (defun ensure-info-tables (dir-name)
 253   (or (gethash dir-name *info-tables*)
 254     (let
 255       ((t1 (make-hash-table :test 'equal))
 256        (t2 (make-hash-table :test 'equal)))
 257       (setf (gethash dir-name *info-tables*) (list t1 t2)))))
 258
 259 (defun load-html-index (entries)
 260   (dolist (entry entries)
 261     (destructuring-bind (item path id)
 262         entry
 263       (setf (gethash item *html-index*) (cons path id)))))
 264