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   ;; Load the index, but make sure we use a sensible *read-base*.
  67   ;; See bug 1951964.  GCL doesn't seem to have
  68   ;; with-standard-io-syntax.  Is just binding *read-base* enough?  Is
  69   ;; with-standard-io-syntax too much for what we want?
  70   (let*
  71       ((subdir-bit (or maxima::*maxima-lang-subdir* "."))
  72        (path-to-index (maxima::combine-path maxima::*maxima-infodir* subdir-bit "maxima-index.lisp"))
  73        (path-to-html-index
  74          (maxima::combine-path maxima::*maxima-infodir* subdir-bit "maxima-index-html.lisp")))
  75     ;; Set the default of the html URL base to be a file URL pointing
  76     ;; to the info dir.
  77     (setf maxima::$url_base (concatenate 'string
  78                              "file://"
  79                              (if maxima::*maxima-lang-subdir*
  80                                  (maxima::combine-path maxima::*maxima-htmldir*
  81                                                        maxima::*maxima-lang-subdir*)
  82                                  maxima::*maxima-htmldir*)))
  83
  84     (handler-case
  85         #-gcl
  86       (with-standard-io-syntax (load path-to-index))
  87       #+gcl
  88       (let ((*read-base* 10.)) (load path-to-index))
  89       (error (condition) (warn (intl:gettext (format nil "~&Maxima is unable to set up the help system.~&(Details: CL-INFO::LOAD-PRIMARY-INDEX: ~a)~&" condition)))))
  90     (handler-case
  91         #-gcl
  92       (with-standard-io-syntax
  93         (load path-to-html-index))
  94       #+gcl
  95       (let ((*read-base* 10.))
  96         (load path-to-html-index))
  97       (error (condition) (warn (intl:gettext (format nil "~&Maxima is unable to set up the help system.~&(Details: CL-INFO::LOAD-PRIMARY-INDEX: ~a)~&" condition)))))))
  98
  99
 100 (defun info-exact (x)
 101   (let ((exact-matches (exact-topic-match x)))
 102     (if (not (some-exact x exact-matches))
 103       (progn
 104         (format t (intl:gettext "  No exact match found for topic `~a'.~%  Try `?? ~a' (inexact match) instead.~%~%") x x)
 105         nil)
 106       (progn
 107         (display-items exact-matches)
 108         (if (some-inexact x (inexact-topic-match x))
 109           (format t (intl:gettext "  There are also some inexact matches for `~a'.~%  Try `?? ~a' to see them.~%~%") x x))
 110         t))))
 111
 112 (defun some-exact (x matches)
 113   (some #'identity (flatten-matches x matches)))
 114
 115 (defun some-inexact (x matches)
 116   (some #'null (flatten-matches x matches)))
 117
 118 (defun flatten-matches (x matches)
 119   ;; OH GODS, SPARE YOUR SERVANT FROM YOUR FIERY WRATH ...
 120   (mapcar #'(lambda (y) (equal y x)) (mapcar #'first (apply #'append (mapcar #'second matches)))))
 121
 122 (defun exact-topic-match (topic)
 123   (setq topic (regex-sanitize topic))
 124   (loop for dir-name being the hash-keys of *info-tables*
 125     collect (list dir-name (exact-topic-match-1 topic dir-name))))
 126
 127 (defun exact-topic-match-1 (topic d)
 128   (let*
 129     ((section-table (first (gethash d *info-tables*)))
 130      (defn-table (second (gethash d *info-tables*)))
 131      (regex1 (concatenate 'string "^" topic "$"))
 132      (regex2 (concatenate 'string "^" topic " *<[0-9]+>$")))
 133     (append
 134       (find-regex-matches regex1 section-table)
 135       (find-regex-matches regex1 defn-table)
 136       (find-regex-matches regex2 section-table)
 137       (find-regex-matches regex2 defn-table))))
 138
 139 (defun info-inexact (x)
 140   (let ((inexact-matches (inexact-topic-match x)))
 141     (when inexact-matches
 142       (display-items inexact-matches))
 143     (not (null inexact-matches))))
 144
 145 ;; MATCHES looks like ((D1 (I11 I12 I12 ...)) (D2 (I21 I22 I23 ...)))
 146 ;; Rearrange it to ((D1 I11) (D1 I12) (D1 I13) ... (D2 I21) (D2 I22) (D2 I23) ...)
 147 (defun rearrange-matches (matches)
 148   (apply #'append (mapcar #'(lambda (di) (let ((d (first di)) (i (second di))) (mapcar #'(lambda (i1) (list d i1)) i))) matches)))
 149
 150 (defun display-items (items)
 151   (let*
 152     ((items-list (rearrange-matches items))
 153      (nitems (length items-list))
 154      wanted)
 155
 156     (loop for i from 0 for item in items-list do
 157       (when (> nitems 1)
 158         (let
 159           ((heading-title (nth 4 (second item)))
 160            (item-name (first (second item))))
 161           (format t "~% ~d: ~a~@[  (~a)~]" i item-name heading-title))))
 162
 163     (setq wanted
 164           (if (> nitems 1)
 165             (prog1
 166               (loop
 167                 for prompt-count from 0
 168                 thereis (progn
 169                           (finish-output *debug-io*)
 170                           (print-prompt prompt-count)
 171                           (finish-output)
 172                           #-(or sbcl cmu) (clear-input)
 173                           (select-info-items
 174                             (parse-user-choice nitems) items-list)))
 175               #-(or sbcl cmu) (clear-input))
 176             items-list))
 177     (finish-output *debug-io*)
 178     (when (consp wanted)
 179       (format t "~%")
 180       (funcall maxima::*help-display-function* wanted)
 181       #+nil
 182       (cond
 183         (maxima::$describe_uses_html
 184          (when maxima::*debug-display-html-help*
 185            (format *debug-io* "wanted = ~A~%" wanted))
 186          (loop for (dir entry) in wanted
 187                do (maxima::display-html-help (car entry))))
 188         (t
 189           (loop for item in wanted
 190                 do (let ((doc (read-info-text (first item) (second item))))
 191                      (if doc
 192                          (format t "~A~%~%" doc)
 193                          (format t "Unable to find documentation for `~A'.~%~
 194                                 Possible bug maxima-index.lisp or build_index.pl?~%"
 195                                  (first (second item)))))))))))
 196
 197 (defun inexact-topic-match (topic)
 198   (setq topic (regex-sanitize topic))
 199   (let ((foo (loop for dir-name being the hash-keys of *info-tables*
 200     collect (list dir-name (inexact-topic-match-1 topic dir-name)))))
 201     (remove-if #'(lambda (x) (null (second x))) foo)))
 202
 203 (defun inexact-topic-match-1 (topic d)
 204   (let*
 205     ((section-table (first (gethash d *info-tables*)))
 206      (defn-table (second (gethash d *info-tables*))))
 207     (append
 208       (find-regex-matches topic section-table)
 209       (find-regex-matches topic defn-table))))
 210
 211 (defun regex-sanitize (s)
 212   "Precede any regex special characters with a backslash."
 213   (pregexp:pregexp-quote s))
 214
 215 (defun find-regex-matches (regex-string hashtable)
 216   (let*
 217       ;; Do the search ignoring case by wrapping the regex-string in
 218       ;; "(?i:...)"
 219       ((regex (concatenate 'string "(?i:" regex-string ")"))
 220        (regex-matches nil))
 221     (maphash
 222      #'(lambda (key value)
 223          (when (pregexp:pregexp-match-positions regex key)
 224            #+nil
 225            (format t "key value: ~S ~S: match ~A~%"
 226                    key value (pregexp:pregexp-match-positiions regex key))
 227            (setq regex-matches (cons `(,key . ,value) regex-matches))))
 228       hashtable)
 229     (stable-sort regex-matches #'string-lessp :key #'car)))
 230
 231 (defun read-info-text (dir-name parameters)
 232   (let*
 233     ((value (cdr parameters))
 234      (filename (car value))
 235      (byte-offset (cadr value))
 236      (char-count (caddr value))
 237      (text (make-string char-count))
 238      (path+filename (merge-pathnames (make-pathname :name filename) dir-name)))
 239     (with-open-file (in path+filename :direction :input)
 240       (unless (plusp byte-offset)
 241         ;; If byte-offset isn't positive there must be some error in
 242         ;; the index.  Return nil and let the caller deal with it.
 243         (return-from read-info-text nil))
 244       (file-position in byte-offset)
 245       (#-gcl read-sequence
 246        #+gcl gcl-read-sequence
 247        text in :start 0 :end char-count))
 248     text))
 249
 250 #+gcl
 251 (defun gcl-read-sequence (s in &key (start 0) (end nil))
 252   (dotimes (i (- end start))
 253     (setf (aref s i) (read-char in))))
 254
 255 ; --------------- build help topic indices ---------------
 256
 257 (defun load-info-hashtables (dir-name deffn-defvr-pairs section-pairs)
 258   (if (and (zerop (length section-pairs))
 259            (zerop (length deffn-defvr-pairs)))
 260     (format t (intl:gettext "warning: ignoring an empty documentation index in ~a~%") dir-name)
 261     (destructuring-bind
 262       (section-hashtable deffn-defvr-hashtable)
 263       (ensure-info-tables dir-name)
 264       (mapc #'(lambda (x) (setf (gethash (car x) section-hashtable) (cdr x))) section-pairs)
 265       (mapc #'(lambda (x) (setf (gethash (car x) deffn-defvr-hashtable) (cdr x))) deffn-defvr-pairs))))
 266
 267 (defun ensure-info-tables (dir-name)
 268   (or (gethash dir-name *info-tables*)
 269     (let
 270       ((t1 (make-hash-table :test 'equal))
 271        (t2 (make-hash-table :test 'equal)))
 272       (setf (gethash dir-name *info-tables*) (list t1 t2)))))
 273
 274 (defun load-html-index (entries)
 275   (dolist (entry entries)
 276     (destructuring-bind (item path id)
 277         entry
 278       (setf (gethash item *html-index*) (cons path id)))))
 279