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