;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*-
;;;;
;;;;  Copyright (c) 2001, Juan Jose Garcia-Ripoll.
;;;;  Copyright (c) 2012, Jean-Claude Beaudoin.
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Lesser General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 3 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../../Copyright' for full details.
;;;;

(in-package "SYSTEM")

;;;;----------------------------------------------------------------------
;;;;  Help files
;;;;

(defun read-help-file (path)
  (let* ((*package* (find-package "CL"))
	 (file (open path :direction :input :external-format '(:utf-8 :lf))))
    (do ((end nil)
	 (h (make-hash-table :size 1024 :test #'eql)))
	(end h)
      (do ((c (read-char file nil)))
	  ((or (not c) (eq c #\^_))
	   (when (not c) (setq end t)))
	)
      (when (not end)
	(let* ((key (read file))
	       (value (read file)))
	  (si::hash-set key h value))))))

(defun dump-help-file (hash-table path &optional (merge nil))
  (let ((entries nil))
    (when merge
      (let ((old-hash (read-help-file path)))
	(push old-hash *documentation-pool*)
	(maphash #'(lambda (key doc)
		     (when doc
		       (do* ((list doc)
			     (doc-type (first list))
			     (string (second list)))
			    (list)
			 (set-documentation key doc-type string))))
		 hash-table)
	(setq hash-table (pop *documentation-pool*))))
    (maphash #'(lambda (key doc)
		 (when (and (symbolp key) doc)
		   (push (cons key doc) entries)))
	     hash-table)
    (setq entries (sort entries #'string-lessp :key #'car))
    (let* ((*package* (find-package "CL"))
	   (file (open path :direction :output :external-format '(:utf-8 :lf))))
      (dolist (l entries)
	(format file "~A~S~%~S~%" #\^_ (car l) (rest l)))
      (close file)
      path)))

(defun search-help-file (key path &aux (pos 0))
  (labels ((bin-search (file start end &aux (delta 0) (middle 0) sym)
	     (declare (fixnum start end delta middle))

	     (when (<= start end)

	       (setq middle (round (+ start end) 2))
	       (file-position file middle)

	       (if (plusp (setq delta (scan-for #\^_ file)))

		 (if (equal key (setq sym (read file)))
		   t
		   (if (string< key sym)
		     (bin-search file start (1- middle))
		     (bin-search file (+ middle delta) end)))
		 (bin-search file start (1- middle)))))
	   (scan-for (char file)
	     (declare (ignore char))
	     (do ((v #\space (read-char file nil nil))
		  (n 0 (1+ n)))
		 ((or (eql v #\^_) (not v)) (if v n -1))
	       (declare (fixnum n)))))
    (when (not (mkcl:probe-file-p path))
      (return-from search-help-file nil))
    (ignore-errors
     (let* ((*package* (find-package "CL"))
	    (file (open path :direction :input :external-format '(:utf-8 :lf)))
	    output)
       (when (and 
	      (not (consp key)) ;; we cannot yet handle (setf foo) as function name. JCB

	      (let ((result (bin-search file 0 (file-length file))))
		result)
	      )

	 (setq output (read file))) ;; What if this read blows up! JCB
       (close file)
       output))))

;;;;----------------------------------------------------------------------
;;;; Documentation system
;;;;

#+mkcl-min
(progn
  (*make-special '*documentation-pool*)
  (setq *documentation-pool* nil)
  (*make-special '*keep-documentation*)
  (setq *keep-documentation* t))
#-mkcl-min
(progn

  (defvar *documentation-pool*
    (list (make-hash-table :test #'eq :size 128) #P"SYS:HELP.DOC")) ;; should be #'equal for (setf foo) handling

  (defvar *keep-documentation* t))

(defun get-documentation (object doc-type &aux output doc-plist)

  (unless (symbolp object) (return-from get-documentation nil))

  (dolist (dict *documentation-pool*)
    (cond ((hash-table-p dict)
	   (when (and (setq doc-plist (gethash object dict))
		      (setq output (getf doc-plist doc-type)))

	     (return-from get-documentation output))
	   )

	  ((and (or (pathnamep dict) (stringp dict))

                #-(and) (or (symbolp object) (functionp object)))
	   (when (and (setq doc-plist (search-help-file object dict))

		      (setq output (getf doc-plist doc-type)))
	     (return-from get-documentation output))

	   )
	  #-(and)
	  (t (format t "~&get-documentation: looking for documentation in unknown source: ~S" dict)(finish-output)) ;; debug JCB
	  )))

(defun set-documentation (object doc-type string)
  (when (not (or (stringp string) (null string)))
    (error "~S is not a valid documentation string" string))

  (unless (symbolp object)
    (if (si::valid-function-name-p object)
	 ;; we silently ignore (setf foobar) function names until we implement proper support. JCB
	(return-from set-documentation string)
      (error "In set-documentation: first argument ~S must be a symbol" object)))

  (let ((dict (first *documentation-pool*)))
    (when (hash-table-p dict)
      (let ((plist (gethash object dict)))
	(setq plist (if string
			(put-f plist string doc-type)
			(rem-f plist doc-type)))
	(if plist
	  (si::hash-set object dict plist)
	  (remhash object dict)))))
  string)

(defun expand-set-documentation (symbol doc-type string)
  (when (and *keep-documentation* string)
    (when (not (stringp string))
      (error "~S is not a valid documentation string" string))
    `((set-documentation ',symbol ',doc-type ,string))))

(defun new-documentation-pool (&optional (size 1024))
  "Args: (&optional hash-size)
Sets up a new hash table for storing documentation strings."
  (push (make-hash-table :test #'eql :size size)
	*documentation-pool*))

(defun dump-documentation (file &optional (merge nil))
  "Args: (filespec &optional (merge nil))
Saves the current hash table for documentation strings to the specificed file.
If MERGE is true, merges the contents of this table with the original values in
the help file."
  (let ((dict (first *documentation-pool*)))
    (when (hash-table-p dict)
      (dump-help-file dict file merge)
      (rplaca *documentation-pool* file))))

#|

;; This stuff is CLTL1 at best. JCB