;;;;
;;;; help.stk           -- Interactive help
;;;;
;;;; Copyright © 2009-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; This file is the re-implementation of a code given to me by
;;;; Michael Feyereisen [mfeyereisen@gmail.com]. Thanks to him for
;;;; having pushed me to finally implement the help function.
;;;;
;;;;           Author: Erick Gallesio [eg@1unice.fr]
;;;;    Creation date: 20-Dec-2009 18:26 (eg)
;;;;


(define-module (stklos help)
  (import SCHEME)
  (export help)

;; ----------------------------------------------------------------------
;; Database reading
;; ----------------------------------------------------------------------
(define (read-database name)
  (let ((f (open-file name "r")))
    (if f
        (let Loop ((res '())
                   (item (read f)))
          (if (eof-object? item)
              (begin (close-port f) res)
              (Loop (cons item res) (read f))))
        ;; file cannot be opened
        (begin
          (eprintf "Warning: cannot open ~S.\n" name)
          '()))))

(define *the-doc*
  (read-database (make-path (%library-prefix 'data) "DOCDB")))


;; ----------------------------------------------------------------------
;; pretty-doc ...
;; ----------------------------------------------------------------------
(define (pretty-doc str)
  ;; Suppress some common adoc things from the doc string
  (let ((hc (do-color (get-repl-color :help)))
        (ac (do-color (get-repl-color :error)))
        (nc (do-color 'normal)))

    ;; Vertical bars or backticks for code
    (set! str (regexp-replace-all "\\|([^|]+)\\|" str (format "~a\\1~a" hc nc)))
    (set! str (regexp-replace-all "`([^`]+)`"     str (format "~a\\1~a" hc nc)))

    ;; Colorize =>
    (set! str (regexp-replace-all "=>"            str (format "~a=>~a" ac hc)))

    ;; Some function calls
    (set! str (regexp-replace-all "{{stklos}}"    str "STklos"))

    ;; The old Skribe linebreak shortcut
    (set! str (regexp-replace-all "@l\n" str " \n"))

    ;; The Scheme examples
    (set! str (regexp-replace-all "@lisp" str hc))
    (set! str (regexp-replace-all "@end lisp" str nc))
    str))

;; ----------------------------------------------------------------------
;; find-documentation
;; ----------------------------------------------------------------------
(define-generic find-documentation)

(define-method find-documentation ((self <symbol>))
  (let* ((doc (assoc self *the-doc*))
         (see (and doc (key-get (cdr doc) :see #f))))
    (cond
      (see
         ;; the symbol is indirectly documented
         (find-documentation see))
      (doc
         ;; found documentation. Format it a little bit
         (pretty-doc (string-append (key-get (cdr doc) :synopsis)
                                    "\n\n"
                                    (key-get (cdr doc) :description)
                                    "\n")))
      ((char=? (string-ref (symbol->string self) 0) #\%)
        (string-append
          "Symbols beginning with '%' are intended for low-level use "
          "and have therefore been\n"
          "left undocumented. Furthermore, they can be changed without notice.\n"
          "Please don't use them.\n"))
      (else
       #f))))


(define-method find-documentation ((self <procedure>))
  (let ((doc (%procedure-doc self)))
    (or doc
        (let ((name (%procedure-name self)))
          (and (string? name)
               (find-documentation (string->symbol name)))))))

(define-method find-documentation ((self <generic>))
  (generic-function-documentation self))

(define-method find-documentation ((self <method>))
  (find-documentation (method-procedure self)))

(define-method find-documentation ((self <syntax>))
  (find-documentation (%syntax-expander self)))

(define-method find-documentation ((self <parameter>))
  (let ((name (%parameter-name self)))
    (and (string? name)
         (find-documentation (string->symbol name)))))

(define-method find-documentation (obj)
  #f)

;; ----------------------------------------------------------------------
;; help
;; ----------------------------------------------------------------------
#|
<doc EXT help
 * (help obj)
 * (help)
 *
 * When called with an argument, |help| tries to give some help on the
 * given object, which could be a symbol, a procedure, a generic function
 * or a method. Whe called called without arguments, |help| enters a
 * read-help-print loop. The documentation for an object is searched in
 * the object itself or, if absent, in STklos documentation.  Inserting
 * the documentation in an objet is very similar to Emacs docstrings: a
 * documentation string is defined among the code. Exemples of such
 * strings are given below
 * @lisp
 * (define (foo n)
 *   "If the function body starts with a string, it's a docstring"
 *   (+ n 1))
 *
 * (define-generic bar
 *   :documentation "Generic function docsting for bar")
 *
 * (define-method bar ((x <integer>))
 *   "Probably less useful: as in functions, methods can have docstrings"
 *   (- x 1))
 * @end lisp
doc>
|#

;; Returns the name of the object, if it is known or #f
(define-generic object-name)

(define-method object-name ((obj <procedure>))
  (let ((name (%procedure-name obj)))
    (if (string? name)
        (string->symbol name)
        obj)))

(define-method object-name ((obj <syntax>))
  ;; syntax has always a name
  (string->symbol (%syntax-name obj)))

(define-method object-name ((obj <generic>))
  (generic-function-name obj))

(define-method object-name ((obj <method>))
  (object-name (method-generic-function obj)))

(define-method object-name ((obj <parameter>))
  (let ((name (%parameter-name obj)))
    (if (string? name)
        (string->symbol name)
        obj)))

(define-method object-name (obj)
  obj)



;; Returns the signature of an object in a human-friendly form.
;; (f x y), or
;; (_ x y)  if it is unnamed.
(define-generic object-signature)

(define-method object-signature ((obj <procedure>))
  (let ((sig (and (closure? obj) (procedure-formals obj))))
    (and sig (cons (object-name obj) sig))))

(define-method object-signature ((obj <syntax>))
  (let ((sig (procedure-formals (%syntax-expander obj))))
    (and sig (cons (object-name obj) sig))))

(define-method object-signature ((obj <method>))
  (let ((sig (procedure-formals (method-procedure obj))))
    (and sig (cons (object-name obj) sig))))

(define-method object-signature ((obj <parameter>))
  #f)

(define-method object-signature (obj)
  #f)

;; ======================================================================
;; Help with a parameter

(define-method help (obj)
  (let ((doc  (find-documentation obj))
        (sig  (object-signature obj))
        (name (object-name obj))
        (pr   (lambda (str)
                (printf "  ~a\n" (regexp-replace-all "\n" str "\n  ")))))
    (cond
       ((or sig doc)
         ;; Documentation or signature found
         (display (ansi-color 'bold 'yellow (format #f "Help for ~a:" name) 'normal "\n"))
         (when sig
           (display (ansi-color 'bold "Signature:" 'normal (format #f "\n  ~S\n" sig))))
         (when doc
           (display (ansi-color 'bold "Documentation:" 'normal "\n"))
           (pr doc)))

      ((symbol? obj)
         ;; We have a symbol and no documentation in the database. Perhaps, it's a closure
         ;; with embedded documentation sting. Look at symbol value.
       (let ((val (symbol-value* obj (current-module) #f)))
         (if val
             (help val)
             (display (ansi-color 'bold 'yellow
                                  (format "No help for ~a" obj) 'normal "\n")))))

      (else
         ;; We have lost
         (display (ansi-color 'bold 'yellow (format #f "No help for ~a" name)
                              'normal "\n"))))))

;; ======================================================================
;; Help without parameter
(define-method help ()
  ;; Interactive help
  (display
   (do-color (get-repl-color :help)
             "You are in the interactive STklos help.\n"
             "Note: This interactive help is for querying symbols. If you want\n"
             "a quick help with REPL commands instead, go back to the REPL and\n"
             "enter ,h (comma-h) there.\n\n"
             "Type ^D (or enter #eof) to exit and go back to the REPL.\n"))
  (let Loop ((prompt (do-color (get-repl-color :help-prompt)
                               "help> " 'none)))
    (display prompt) (flush-output-port)
    (let ((name  (read))
          (color (get-repl-color :error)))
      (unless (eof-object? name)
        (if (symbol? name)
            (help name)
            (display (do-color color "help only accepts symbols.\n")))
        (Loop prompt))))
  (display "done.\n"))

) ;; End of module (stklos library)

(select-module STklos)
(import (stklos help))


(provide "stklos/help")
