/* libsizzle/doc.c - documentation support
 
  Copyright (C) 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 
  This 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, or (at your option)
  any later version.
  
  This software 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 package; see the file COPYING.  If not, write to
  the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  Boston, MA 02111-1307, USA.  */

#if HAVE_CONFIG_H
# include <config.h>
#endif 

#include <assert.h>
#include <stdio.h>
#include <string.h>

#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#include "alloc.h"
#include "libpath.h"
#include "node.h"
#include "validate.h"
#include "capi.h"
#include "port.h"
#include "vector.h"
#include "doc.h"

static int
try_to_load_docstring (zzz_scm_t symbol, zzz_scm_t * docstring)
{
  static int already_warned = 0;
  FILE * f;
  int buf_len = 1024;
  char * read_buf = zzz_malloc (buf_len);
  int doc_len_buf = 1024;
  char * doc_buf;
  char * p;
  char * name = string_val (symbol_name (symbol));

  *docstring = zzz_false_value;
  /* This is for testing in the source tree.  A docstring file in a
     directory called ../data overrides the installed.  

     FIXME: Maybe remove this when docstring testing is complete.  */
  f = fopen ("../data/docstrings.txt", "r");
  if (!f)
    f = fopen (LIBRARY_DIR "/docstrings.txt", "r");
  if (f)
    {
      while (fgets (read_buf, buf_len, f) != NULL)
	{
	  if (!strncmp (read_buf, name, strlen (name)))
	    {
	      doc_buf = zzz_malloc (doc_len_buf);
	      doc_buf[0] = '\0';
	      while (fgets (read_buf, buf_len, f) != NULL)
		{
		  if (strchr (read_buf, '\f'))
		    break;
		  strcat (doc_buf, read_buf);
		  doc_buf = zzz_realloc (doc_buf, doc_len_buf +
					 strlen (read_buf), doc_len_buf);
		  doc_len_buf += strlen (read_buf);
		}
	      fclose (f);
	      if ((p = strchr (doc_buf, '\0')))
		{
		  while (p > doc_buf && p[-1] == '\n')
		    p--;
		  *p = '\0';
		}
	      *docstring = zzz_make_ro_string (doc_buf, strlen (doc_buf));
	      zzz_free (doc_buf, doc_len_buf);
	      zzz_free (read_buf, buf_len);
	      return 1;
	    }
	  else
	    {
	      /* Skip documentation entry.  */
	      while (fgets (read_buf, buf_len, f) != NULL)
		{
		  if (strchr (read_buf, '\f'))
		    break;
		}
	    }
	}
      fclose (f);
    }
  else if (!already_warned)
    {
      fprintf (stderr, "warning: cannot find docstring file\n");
      already_warned = 1;
    }
  zzz_free (read_buf, buf_len);
  return 0;
}

/*:doc
  documentation
  (documentation obj) => object
  Return the documentation object of the object @var{obj}.
  doc:*/
#define FUNC_NAME "documentation"
static result_t
documentation_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t doc;
  if (func_p (obj) || form_p (obj))
    {
      doc = func_doc (obj);
      if (!doc)
	{
	  try_to_load_docstring (func_name (obj), &doc);
	  func_doc (obj) = doc;
	}
    }
  else if (closure_p (obj))
    {
      doc = lambda_doc (closure_proc (obj));
      if (!doc)
	{
	  try_to_load_docstring (lambda_name (closure_proc (obj)), &doc);
	  lambda_doc (closure_proc (obj)) = doc;
	}
    }
  else if (symbol_p (obj))
    {
      try_to_load_docstring (obj, &doc);
    }
  else
    doc = zzz_false_value;
  *result = doc;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  set-documentation!
  (set-documentation! proc doc) => *unspecified*
  Set @var{doc} as the documentation object for the procedure object
  @var{proc}.
  doc:*/
#define FUNC_NAME "set-documentation!"
static result_t
set_documentation_x_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t doc,
			  zzz_scm_t * result)
{
  if (func_p (obj))
    func_doc (obj) = doc;
  else if (func_p (obj))
    func_doc (obj) = doc;
  else if (closure_p (obj))
    lambda_doc (closure_proc (obj)) = doc;
  else if (symbol_p (obj))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string
	 (_("documentation objects for symbols cannot be set"), -1));
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

static void
describe_object (const char * s_func_name, zzz_scm_t obj, int verbose)
{
  zzz_scm_t temp, doc;
  char * text = NULL;
  zzz_scm_t name = NULL;
  struct zzz_print_state print_state = {/*  0,  */0};

  if (func_p (obj))
    {
      text = "Primitive procedure";
      doc = func_doc (obj);
      if (!doc)
	{
	  try_to_load_docstring (func_name (obj), &doc);
	  func_doc (obj) = doc;
	}
      name = func_name (obj);
    }
  else if (form_p (obj))
    {
      text = "Syntactic form";
      doc = func_doc (obj);
      if (!doc)
	{
	  try_to_load_docstring (func_name (obj), &doc);
	  func_doc (obj) = doc;
	}
      name = func_name (obj);
    }
  else if (closure_p (obj))
    {
      text = "Procedure";
      doc = lambda_doc (closure_proc (obj));
      if (!doc)
	{
	  try_to_load_docstring (lambda_name (closure_proc (obj)), &doc);
	  lambda_doc (closure_proc (obj)) = doc;
	}
      name = lambda_name (closure_proc (obj));
    }
  else if (symbol_p (obj))
    {
      text = "symbol";
      try_to_load_docstring (obj, &doc);
      name = obj;
    }
  else
    {
      doc = NULL;
      text = "Ordinary scheme object";
      name = NULL;
    }
  if (name)
    {
      zzz_port_print (zzz_current_out_port, name, &print_state, &temp);
      zzz_port_puts (zzz_current_out_port, ": ", 2, &temp);
    }
  zzz_port_puts (zzz_current_out_port,
		 text, strlen (text), &temp);
  if (verbose)
    {
      zzz_port_puts (zzz_current_out_port, "\n", 1, &temp);
      if (doc)
	{
	  zzz_port_puts (zzz_current_out_port,
			 "Documentation:\n", 15, &temp);
	  zzz_port_print (zzz_current_out_port, doc, &print_state, &temp);
	}
      else
	{
	  zzz_port_puts (zzz_current_out_port,
			 "No documentation available.", 27, &temp);
	}
    }
  zzz_port_puts (zzz_current_out_port, "\n", 1, &temp);
}

/*:doc
  describe
  (describe obj) => *unspecified*
  Print all available information about the given object @var{obj} to 
  the current output port.
  doc:*/
#define FUNC_NAME "describe"
static result_t
describe_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  describe_object (s_func_name, obj, 1);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  apropos
  (apropos str) => *unspecified*
  Print information about all procedures which have @var{str} somewhere
  in their name to the current output port.
  doc:*/
#define FUNC_NAME "apropos"
static result_t
apropos_func (zzz_scm_t env, zzz_scm_t str, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t temp, sym, res;
  unsigned int x;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  for (x = 0; x < vector_len (zzz_symbol_table); x++)
    {
      temp = zzz_vector_get (zzz_symbol_table, x);
      while (cons_p (temp))
	{
	  sym = car (temp);
	  assert (symbol_p (sym));

	  if (strstr (string_val (symbol_name (sym)),
		      string_val (str)))
	    {
	      if (zzz_get_symbol_value (zzz_current_environment, sym, &res) == 
		  RESULT_SUCCESS)
		{
		  if (procedure_p (res))
		    {
		      describe_object (s_func_name, res, 0);
		    }
		  else
		    describe_object (s_func_name, sym, 0);
		}
	    }
	  temp = cdr (temp);
	}
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

result_t
zzz_init_doc (void)
{
  zzz_define_function ("documentation",
		       (zzz_prim_t) documentation_func, argv_1_0_0);
  zzz_define_function ("set-documentation!",
		       (zzz_prim_t) set_documentation_x_func, argv_2_0_0);
  zzz_define_function ("describe", (zzz_prim_t) describe_func, argv_1_0_0);
  zzz_define_function ("apropos", (zzz_prim_t) apropos_func, argv_1_0_0);
  return RESULT_SUCCESS;
}
