;;(in-package "SI"  )

(defpackage "INFO" (:use :CL-USER :REGEXP))
(export '(idescribe))

(eval-when (compile)

(proclaim '(ftype (function (t t &optional fixnum) fixnum) string-match))
(proclaim '(ftype (function (fixnum) fixnum)
		  match-beginning match-end)))

(defvar *case-fold-search* nil)
(defvar *match-data* nil)
(defvar *info-data* nil)
(defvar *current-info-data* nil)

(defvar *info-paths*
  '("" "/usr/info/" "/usr/local/lib/info/" "/usr/local/info/"
    "/usr/local/gnu/info/" "/u2/local/src/lisp/"))

(defvar *old-lib-directory* nil)
(defvar *lib-directory* nil)

(defvar *last-info-file* nil)
;;(defvar *default-info-files* '( "gcl-si.info" "gcl-tk.info" "gcl.info"))
(defvar *default-info-files* '( "gcl-si.info"))


(defun string-match (pat s &optional (start 0) (end (length s)))
  (setf *match-data*
	(multiple-value-list
	    (regexp:match pat s :start start :end end :case-insensitive *case-fold-search*)))
  (if (first *match-data*)
      ;; Found the string
      (regexp:match-start (elt *match-data* 0))
    -1)
  )


#|
(defun match-beginning (k)
  (regexp:match-start (elt *match-data* k)))

(defun match-end (k)
  (regexp:match-end (elt *match-data* k)))
|#

(defmacro match-beginning (k)
  `(regexp:match-start (elt *match-data* ,k)))

(defmacro match-end (k)
  `(regexp:match-end (elt *match-data* ,k)))

(eval-when (compile eval)
(defmacro while (test &body body)
  `(loop while ,test do ,@ body))
(defmacro f (op x y)
   `(,op (the fixnum ,x) (the fixnum ,y)))
)

(eval-when (compile eval load)
(defun sharp-u-reader (stream subchar arg)
  subchar arg
  (let ((tem (make-array 10
			 :element-type 'string-char
			 :fill-pointer 0
			 :adjustable t)))
    (or (eql (read-char stream) #\")
	(error "sharp-u-reader reader needs a \" right after it"))
    (loop
      (let ((ch (read-char stream)))
	(cond ((eql ch #\") (return tem))
	      ((eql ch #\\)
		 (setq ch (read-char stream))
		 (setq ch (or (cdr (assoc ch '((#\n . #\newline)
					       (#\t . #\tab)
					       (#\r . #\return))))
			      ch))))
	(vector-push-extend ch tem)))
    tem))


(set-dispatch-macro-character #\# #\u #'sharp-u-reader)
)

#|
(defun re-quote-string (str)
  (regexp:regexp-quote str))

(defun get-match (string i)
  (subseq string (match-beginning i) (match-end i)))
|#

(defmacro re-quote-string (str)
  `(regexp:regexp-quote ,str))
(defmacro get-match (string i)
  `(subseq ,string (match-beginning ,i) (match-end ,i)))

;;; Read the contents of a file into a string.
(defun file-to-string (file &optional (start 0)
			    &aux (len 0))
  (with-open-file (st file)
    (setq len (file-length st))
    (or (and (<= 0 start ) (<= start len))
	(error "illegal file start ~a" start))
    (let ((tem (make-array (- len start) :element-type 'string-char)))
      (if (> start 0)
	  (file-position st start))
      (read-char-sequence tem st)
      tem)))

;;; Convert the string of digits into the equivalent integer 
(defun atoi (string start &aux (ans 0) (ch 0) (len (length string)))
  (declare (string string))
  (declare (fixnum start ans ch len))
  (while (< start len)
    (setq ch (char-code (aref string start)))
    (setq start (+ start 1))
    (setq ch (- ch #.(char-code #\0)))
    (cond ((and (>= ch 0) (< ch 10))
	     (setq ans (+ ch (* 10 ans))))
	  (t (return nil))))
  ans)
  
(defun info-get-tags (file &aux (lim 0) tags files
			   (*case-fold-search* t))
  (declare (fixnum lim))
  (let ((s (file-to-string file)) (i 0))
    (declare (fixnum i) (string s))
    ;; Find "Indirect" in the file.  This means that the info file is really
    ;; split into several files.
    (when (f >= (string-match #u"[\n]\\+Indirect:" s) 0)
	     ;; Find the end of this indirection table.
	     (setq i (match-end 0))
	     (setq lim (string-match #u"" s i))
	     ;; Extract the corresponding names and offsets and save the result.
	     (while (f >= (string-match #u"\n\\([^\n]\\+\\): \\([0-9]\\+\\)" s i lim) 0)
	       (setq i (match-end 0))
	       (setq files (cons
			    (cons
			     (atoi s (match-beginning 2))
			     (get-match s 1)
			     )
			    files))
	       )
	     )
    ;; Now find the tag table.  Extract out the tags
    (when (f >=  (string-match #u"[\n]\\+Tag Table:" s i) 0)
      (setq i (match-end 0))
      (when (f >= (string-match "" s i) 0)
	(setq tags (subseq s i (match-end 0)))
	)
      )
    (if files
	(or tags
	    (info-error "Need tags if have multiple files")))
    (list* tags (nreverse files))
    )
  )

;; Get all the nodes that match the pattern
(defun get-nodes (pat node-string &aux (i 0) ans
		      (*case-fold-search* t) )
  (declare (fixnum i))
  (when node-string
    (setq pat (string-concat #u"Node: \\([^]*"
			     (re-quote-string pat)
			     #u"[^]*\\)"))
    (while (f >= (string-match pat node-string i) 0)
      (setq i (match-end 0))
      (setq ans (cons (get-match node-string 1)
		      ans))
      )
    (nreverse ans))
  )

(defun get-index-node ()
  (or (third *current-info-data*) 
      (let* (s
	     (node-string (car (nth 1 *current-info-data*)))
	     (node (and node-string
			(car (get-nodes "index" node-string))))
	     )
	;;(format t "get-index-node:  node-string = ~a~%" node-string)
	;;(format t "get-index-node:  node = ~a~%" node)
	(when node
	  (setq s (show-info node nil nil))
	  (setf (third *current-info-data*) s)))))

(defun nodes-from-index (pat  &aux (i 0) ans
			      (*case-fold-search* t) )
  ;;(format t "nodes-from-index (~a)~%" pat)

  (let ((index-string (get-index-node)))
    ;;(format t "got index node.  Searching for ~a...~%" pat)
    ;;(format t "index-string = ~a" index-string)
    (when index-string
      (setq pat (string-concat #u"\n\\* \\("
			       (re-quote-string pat)
			       #u"\\):[ \t]\\+\\([^\t\n,.]\\+\\)"))
      (while (f >= (string-match pat index-string i) 0)
	(setq i (match-end 0))
	(setq ans (cons (cons (get-match index-string 1)
			      (get-match index-string 2))
			ans))
	;;(format t "nodes-from-index:  found at ~a-~a~%" (match-beginning 0) (match-end 0))
	;;(format t "nodes-from-index:  ans = ~a~%" ans)
	)
      )
    (nreverse ans)))

;; Get the starting index for the desired node
(defun get-node-index (pat node-string &aux (node pat) )
  (cond ((null node-string)
	   0)
	(t
	   (setq pat (string-concat "Node: "
				    (re-quote-string pat)
				    "\\([0-9]\\+\\)"))
	   (cond ((f >= (string-match pat node-string) 0)
		    (atoi node-string (match-beginning 1)))
		 (t
		    (info-error "can't find node ~s" node) 0)))))

#|
(defun all-matches (pat st &aux (start 0) )
  (declare (fixnum start))
  (loop while (>= (setq start (string-match pat st start)) 0)
	do nil ;(print start)
	collect (list start (setq start (match-end 0)))))
|#


(defmacro node (prop x)
  `(nth ,(position prop '(string begin end header name
			  info-subfile
			  file tags)) ,x)) 

(defun node-offset (node)
  (+ (car (node info-subfile node))
     (node begin node)))


(defun setup-info (name &aux tem file)
  (or (eq *old-lib-directory* *lib-directory*)
      (progn
	(setq *old-lib-directory* *lib-directory*)
	(push (string-concat *lib-directory* "info/")
	      *info-paths*)
	#+gcl
	(setq *info-paths* (si::fix-load-path *info-paths*))
	))
  (cond ((or (equal name "DIR"))
	   (setq name "dir")))
  (setq file (file-search name *info-paths* '("" ".info") nil))
  ;;(format t "setup-info:  file = ~a~%" file)
  (cond ((and (null file)
	      (not (equal name "dir")))
	   ;;(format t "setup-info: null file and not dir")
	   (let* (
		  (tem (show-info "(dir)Top" nil nil))
		  (pat (string-concat "\\(([^(]*" (re-quote-string name)))
		  *case-fold-search*)
	     (cond ((f >= (string-match
			   (string-concat pat "(.info)?)\\)") tem) 0)
		      (setq file  (get-match tem 1))))
	     )))
  ;;(format t "setup-info:  again file = ~a~%" file)
  (cond (file
	   ;;(format t "setup-info: file ~a~%" file)
	   ;;(format t "na = ~a~%" (namestring (truename file)))
	   ;;(format t "info-data = ~a~%" *info-data*)
	   ;;(format t "assoc na = ~a~%" (assoc (namestring (truename file)) *info-data* :test 'equal))
	   (let* ((na (namestring (truename file))))
	     (cond ((setq tem (assoc na *info-data* :test 'equal))
		      ;;(format t "Found na in *info-data*.~%")
		      (setq *current-info-data* tem)
		      )
		   (t
		      ;;(format t "Did not find na in *info-data*~%")
		      (setq *current-info-data*
			    (list na (info-get-tags na) nil))
		      (setq *info-data* (cons *current-info-data* *info-data*))
		      ))))
	(t (format t "(not found ~s)" name)))
  nil)
			  
(defun get-info-choices (pat type)
  ;;(format t "get-info-choices (~a ~a)~%" pat type)
  (if (eql type 'index)
      (nodes-from-index pat )
    (get-nodes pat (car (nth 1 *current-info-data*)))))

(defun add-file (v file &aux (lis v))
  (while lis
    (setf (car lis) (list (car lis) file))
    (setq lis (cdr lis)))
  v)

(defun info-error (&rest l)
  (apply 'error l))

;; cache last file read to speed up lookup since may be gzipped..
(defun info-get-file (pathname)
  (setq pathname
	(merge-pathnames pathname
			 (car *current-info-data*)))
  (cdr 
   (cond ((equal (car *last-info-file*) pathname)
	    *last-info-file*)
	 (t (setq *last-info-file*
		  (cons pathname (file-to-string pathname)))))))

(defun info-subfile (n  &aux )
;  "For an index N return (START . FILE) for info subfile
; which contains N.   A second value bounding the limit if known
; is returned.   At last file this limit is nil."
  (let ((lis (cdr (nth 1 *current-info-data*)))
	ans lim)
    (and lis (>= n 0)
	 (dolist (v lis)
	   (cond ((> (car v) n )
		    (setq lim (car v))
		    (return nil)))
	   (setq ans v)
	   ))
    (values (or ans (cons 0 (car *current-info-data*))) lim)))

;;used by search
(defun info-node-from-position (n &aux  (i 0))
  (let* ((info-subfile (info-subfile n))
	 (s (info-get-file (cdr info-subfile)))
	 (end (- n (car info-subfile))))
    (while (f >=  (string-match #u"" s i end) 0)
      (setq i (match-end 0)))
    (setq i (- i 1))
    (if (f >= (string-match
	       #u"[\n][^\n]*Node:[ \t]\\+\\([^\n\t,]\\+\\)[\n\t,][^\n]*\n"  s i) 0)
	(let* ((i (match-beginning 0))
	       (beg (match-end 0))
	       (name (get-match s 1))
	       (end (if (f >= (string-match "[]" s beg) 0)
			(match-beginning 0)
		      (length s)))
	       (node (list* s beg end i name info-subfile
			    *current-info-data*)))
	  node))))
    
(defun show-info (name  &optional position-pattern
			#+gcl (use-tk *tk-connection*)
			#+clisp unused
			&aux info-subfile  
			file
			(initial-offset 0)(subnode -1))
  #+clisp
  (declare (ignore unused))
  (declare (fixnum subnode initial-offset))
;;; (pat . node)
;;; node
;;; (node file)
;;; ((pat . node) file)
;;;  (print (list name position-pattern use-tk))
  ;;(format t "show-info:~%   name = ~a~%   pospat  = ~a~%   infosub = ~a~%   file = ~a~%   offset = ~a~%   subnode = ~a~%" name position-pattern info-subfile file initial-offset subnode)
  (progn ;decode name
    (cond ((and (consp name) (consp (cdr name)))
	     (setq file (cadr name)
		   name (car name))))
    (cond ((consp name)
	     (setq position-pattern (car name) name (cdr name)))))
  (or (stringp name) (info-error "bad arg"))
  #+gcl (waiting *info-window*)  
  ;;(format t "file = ~a, name = ~a~%" file name)
  (cond ((f >= (string-match "^\\(([^(]\\+)\\)\\([^)]*\\)" name) 0)
	   ;; (file)node
	   (setq file (get-match name 1))
	   (setq name (get-match name 2))
	   (if (equal name "")(setq name "Top"))))
  ;;(format t "file = ~a, name = ~a~%" file name)
  (if file  (setup-info file))
  (let ((indirect-index (get-node-index name
					(car (nth 1 *current-info-data*)))))
    (setq info-subfile (info-subfile indirect-index))
    (let* ((s (info-get-file (cdr info-subfile)))
	   (start (- indirect-index (car info-subfile))))
      (cond ((f >= (string-match (string-concat #u"[\n][^\n]*Node:[ \t]\\+"
						(re-quote-string name)
						#u"[,\t\n][^\n]*\n")
				 s start)
		0)
	       (let* ((i (match-beginning 0))
		      (beg (match-end 0))
		      (end (if (f >= (string-match "[]" s beg) 0)
			       (match-beginning 0)
			     (length s)))
		      (node (list* s beg end i name info-subfile
				   *current-info-data*)))
		 #+clisp
		 (declare (ignore node))
		 
		 (cond (position-pattern
			  (setq position-pattern (re-quote-string position-pattern))

		      (let (*case-fold-search*)
			(if (or
			     (f >= (setq subnode
					 (string-match
					  (string-concat
					   #u"\n --\\? [A-Za-z ]\\+: "
					   position-pattern
					   #u"[ \n]")
					  s beg end)) 0)
			     (f >= (string-match position-pattern s beg end) 0))
			    (setq initial-offset
				  (- (match-beginning 0) beg))
			  ))))
		 (let ((e (if (and (>= subnode 0)
				   (f >= (string-match #u"\n --\\? [A-Z]"
						       s (+ beg 1 initial-offset)
						  end)
				      0))
			      (match-beginning 0)
			    end)))
		   (subseq s (+ initial-offset beg) e )
		   )))
	    (t (info-error "Can't find node  ~a?" name)
	       #+gcl
	       (end-waiting  *info-window*)
	       ))
      )))

(defun info-aux (x dirs)
  ;;(format t "info-aux (~a ~a)~%" x dirs)
  (loop for v in dirs
	do (setup-info v)
	append (add-file (get-info-choices x 'node) v)
	append (add-file (get-info-choices x 'index) v))
  ;;(format t "info-aux done~%")
  )

(defun info-search (pattern &optional start end &aux limit)
;  "search for PATTERN from START up to END where these are indices in
;the general info file.   The search goes over all files."
  (or start (setq start 0))
  (while start
    (multiple-value-bind
	  (file lim)
	(info-subfile start)
      (setq limit lim)
      (and end limit (<  end limit) (setq limit end))

      (let* ((s  (info-get-file (cdr  file)))
	     (beg (car file))
	     (i (- start beg))
	     (leng (length s)))
	(cond ((f >= (string-match pattern s i (if limit (- limit beg) leng)) 0)
		 (return-from info-search (+ beg (match-beginning 0))))))
      (setq start lim)))
  -1)

#+debug ; try searching
(defun try (pat &aux (tem 0) s )
 (while (>= tem 0)
  (cond ((>= (setq tem (info-search pat tem)) 0)
	 (setq s (cdr *last-info-file*))
	 (print (list
		 tem
		 (list-matches s 0 1 2)
		 (car *last-info-file*)
		 (subseq s
			 (max 0 (- (match-beginning 0) 50))
			 (min (+ (match-end 0) 50) (length s)))))
	 (setq tem (+ tem (- (match-end 0) (match-beginning 0))))))))
   
(defun idescribe (name)
  "Lookup NAME in the info file and print the information"
  (let* ((items (info-aux name *default-info-files*)))
    (dolist (v items)
      (when (cond ((consp (car v))
		     (equalp (caar v) name))
		  (t (equalp (car v) name)))
	(format t "~%From ~a:~%" v)
	(princ (show-info v nil nil)))))
  (values))
  
(defun file-search (name paths exts &optional unused)
  (declare (ignore unused))
  (dolist (p paths)
    (dolist (e exts)
      (let ((file (string-concat p name e)))
	(when (open file :direction :probe)
	  (return-from file-search file))
	)
      )
    )
  nil)

#|
(defvar *info-window* nil)
(defvar *tk-connection* nil)

(defun info-error (&rest l)
  (if *info-window*
      (tkerror (apply 'format nil l))
    (apply 'error l)))

(defun waiting (win)
  (and *tk-connection*
       (fboundp win)
       (winfo :exists win :return 'boolean)
       (funcall win :configure :cursor "watch")))

(defun end-waiting (win) (and (fboundp win)
			   (funcall win :configure :cursor "")))

(defun info (x &optional (dirs *default-info-files*)  &aux wanted
	       *current-info-data* file position-pattern)
  (let ((tem (info-aux x dirs)))
    (cond
     #+gcl
     (*tk-connection*
      (offer-choices tem dirs)
       )
     (t

    (when tem
	  (loop for i from 0 for name in tem with prev
		 do (setq file nil position-pattern nil)
		 (progn ;decode name
		   (cond ((and (consp name) (consp (cdr name)))
			  (setq file (cadr name)
				name (car name))))
		   (cond ((consp name)
			  (setq position-pattern (car name) name (cdr name)))))
		 (format t "~% ~d: ~@[~a :~]~@[(~a)~]~a." i
			 position-pattern
			 (if (eq file prev) nil (setq prev file)) name))
	  (format t "~%Enter n, all, none, or multiple choices eg 1 3 : ")
	  (let ((line (read-line)) (start 0) val)
	    (if (equal line "") (setq line (read-line)))
	    (while (multiple-value-setq
		    (val start)
		    (read-from-string line nil nil :start start))
	      (cond ((numberp val)
		     (setq wanted (cons val wanted)))
		    (t (setq wanted val) (return nil))))
	    (cond ((consp wanted)(setq wanted (nreverse wanted)))
		  ((symbolp wanted)
		   (setq wanted (and
				 (equal (symbol-name wanted) "ALL")
				 (loop for i below (length tem) collect i)))))
	    (if wanted
		(format t "~%Info from file ~a:" (car *current-info-data*)))
	    (loop for i in wanted
		   do (princ(show-info (nth i tem))))))))))

	     
;; idea make info_text window have previous,next,up bindings on keys
;; and on menu bar.    Have it bring up apropos menu. allow selection
;; to say spawn another info_text window.   The symbol that is the window
;; will carry on its plist the prev,next etc nodes, and the string-to-file
;; cache the last read file as well.   Add look up in index file, so that can
;; search an indtqex as well.   Could be an optional arg to show-node
;; 



(defun default-info-hotlist()
  (namestring (merge-pathnames "hotlist" (user-homedir-pathname))))

(defvar *info-window* nil)

(defun add-to-hotlist (node )
  (if (symbolp node) (setq node (get node 'node)))
  (cond
   (node
    (with-open-file
     (st (default-info-hotlist)
	 :direction :output
	 :if-exists :append
	 :if-does-not-exist :create)
     (cond ((< (file-position st) 10)
	    (princ  #u"\nFile:\thotlist\tNode: Top\n\n* Menu: Hot list of favrite info items.\n\n" st)))
     (format st "* (~a)~a::~%" 
	     (node file node)(node name node))))))

(defun list-matches (s &rest l)
  (loop for i in l 
	 collect
	 (and (f >= (match-beginning i) 0)
	      (get-match s i))))

|#

	
;;; Local Variables: ***
;;; mode:lisp ***
;;; comment-column:0 ***
;;; comment-start: ";;; " ***
;;; End: ***


