src/cl-info.lisp

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