[Chicken-users] Re: texinfo

[Linh Dang]

On 7 May 2004, address@hidden wrote:

> Linh Dang wrote:
>> On 5 May 2004, address@hidden wrote:
>>
>>> BTW, the hen.el works quite good. But apropos doesn't work, and
>>> I'm not sure why. I've attached a slightly changed version,
>>> that also doesn't depend on the lolevel unit.
>> I've tried your changes but it doesn't seem to work with 1.43
>> (segmentation fault). does your change need 1.46?
>
> Hm. Strange. But getting the newest version of Chicken might be ok.

I think I narrowed it down. You use ##csi#name-of-symbols-matching
instead of ##csi#symbols-matching. I fixed that and your version of
apropos now works correctly.

Regards
--
Linh


----- hen.el -----
;;; HEN.EL ---  mode for editing chicken code

;; Copyright (C) 2004 Linh Dang

;; Author: Linh Dang <linhd@>
;; Maintainer: Linh Dang <linhd@>
;; Created: 19 Apr 2004
;; Version: 1
;; Keywords:


;; 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 1, 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.

;; A copy of the GNU General Public License can be obtained from this
;; program's author (send electronic mail to <linhd@>) or from the
;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
;; USA.

;; LCD Archive Entry:
;; hen|Linh Dang|<linhd@>
;; | mode for editing chicken code
;; |$Date: 2004/05/08 02:01:12 $|$Revision: 1.20 $|~/packages/hen.el

;;; Commentary:
;; Hen is a mode derived from scheme-mode and is specialized for
;; editing chicken scheme.
;; This mode assumes:
;;     - the user has chicken.info install
;;     - the csi executable can be launch as "csi"
;;     - the #csi##oblist and co are available from oblist library

;;; Change log:
;; $Log: hen.el,v $
;; Revision 1.20  2004/05/08 02:01:12  linhd
;; use felix version
;;
;; Revision 1.19  2004/05/03 14:43:37  linhd
;; huh
;;
;; Revision 1.18  2004/04/29 17:45:03  linhd
;; cool
;;
;; Revision 1.17  2004/04/29 17:29:07  linhd
;; ok
;;
;; Revision 1.16  2004/04/23 15:33:49  linhd
;; minor
;;
;; Revision 1.15  2004/04/23 15:33:26  linhd
;; add doc
;;
;; Revision 1.14  2004/04/23 15:31:24  linhd
;; almost complete
;;
;; Revision 1.13  2004/04/23 15:29:04  linhd
;; cool
;;
;; Revision 1.12  2004/04/23 15:01:55  linhd
;; cool
;;
;; Revision 1.11  2004/04/23 13:29:44  linhd
;; before changing to new strategy
;;
;; Revision 1.10  2004/04/22 12:37:50  linhd
;; cool
;;
;; Revision 1.9  2004/04/21 18:42:08  linhd
;; cool
;;
;; Revision 1.8  2004/04/20 14:35:12  linhd
;; huh
;;
;; Revision 1.7  2004/04/20 14:33:36  linhd
;; add info lookup
;;
;; Revision 1.6  2004/04/19 16:30:14  linhd
;; cleanup
;;
;; Revision 1.5  2004/04/19 16:28:21  linhd
;; cool
;; inferior csi works
;;
;; Revision 1.4  2004/04/19 15:47:43  linhd
;; remove <...> symbols
;;
;; Revision 1.3  2004/04/19 15:29:48  linhd
;; huh
;;
;; Revision 1.2  2004/04/19 14:59:26  linhd
;; cool
;;
;; Revision 1.1  2004/04/19 14:52:48  linhd
;; Initial revision
;;

;;; Code:

(defconst hen-version (substring "$Revision: 1.20 $" 11 -2)
  "$Id: hen.el,v 1.20 2004/05/08 02:01:12 linhd Exp $

Report bugs to: Linh Dang <linhd@>")
(defvar hen-load-hook nil
  "*Hooks run after loading hen.")

(require 'scheme)
(require 'info-look)
(require 'compile)

(defconst hen-syntax-table
  (let ((tab (copy-syntax-table scheme-mode-syntax-table)))
    (modify-syntax-entry ?# "_   " tab)
    (modify-syntax-entry ?: "_   " tab)
    (modify-syntax-entry ?\[ "(]  " tab)
    (modify-syntax-entry ?\] ")[  " tab)

    tab))

(defconst hen-font-lock-keywords-1
  (eval-when-compile
    (list
     ;; Declarations
     (list (concat "\\(?:(\\|\\[\\)"
            (regexp-opt
                    '("define"
                      "define-class"
                      "define-const-structure"
                      "define-constant"
                      "define-datatype"
                      "define-external-variable"
                      "define-foreign-type"
                      "define-foreign-variable"
                      "define-form"
                      "define-functor"
                      "define-generic"
                      "define-handy-method"
                      "define-inline"
                      "define-internal-meroon-macro"
                      "define-macro"
                      "define-meroon-macro"
                      "define-method"
                      "define-optionals"
                      "define-reader-ctor"
                      "define-record"
                      "define-record-printer"
                      "define-record-type"
                      "define-retrofitted-generic"
                      "define-signature"
                      "define-structure"
                      "define-syntax"
                      "define-syntax-form"
                      "define-temporary"
                      "define-values") 1)
                   "\\s-+(?\\(\\(\\sw\\|\\s_\\)+\\)")

           '(1 font-lock-keyword-face)
           '(2 font-lock-function-name-face nil t))))
  "Basic font-locking for Hen mode.")

(defconst hen-font-lock-keywords-2
  (append hen-font-lock-keywords-1
   (eval-when-compile
     (list
      ;;
      ;; Control structures.
      (cons
       (concat
        "(" (regexp-opt
             '("begin" "begin0" "begin-form"
               "call-with-current-continuation" "call/cc"
               "call-with-direct-continuation"
               "call-with-input-pipe" "call-with-output-pipe"
               "call-with-input-file" "call-with-output-file"
               "call-with-input-string" "call-with-output-string"
               "call-with-values"

               "case" "case-lambda" "cond" "cond-expand" "condition-case" 
"switch"

               "do" "else" "for-each" "if" "lambda" "when" "while" "if*" 
"unless"

               "let" "let*" "let-syntax" "letrec" "letrec-syntax"
               "and-let*" "let-optionals" "let-optionals*" "let-macro"
               "fluid-let" "let-values" "let*-values" "letrec-values"
               "parameterize"


               "and" "or" "delay" "andmap" "ormap"

               "assert" "ignore-errors" "critical-section" "ensure" "eval-when"

               "with-input-from-file" "with-output-to-file"
               "with-input-from-pipe" "with-output-to-pipe"
               "with-input-from-string" "with-output-to-string"

               "map" "syntax" "syntax-rules") t)
        "\\>") 1)
      ;;
      ;;  `:' keywords as builtins.
      '("quasi\\(?:quote\\)?" . font-lock-builtin-face)
      '("#?\\<:\\sw+\\>" . font-lock-builtin-face)
      '(",@?\\|`" . font-lock-builtin-face)
      '("\\(##\\sw+#\\)" (1 font-lock-builtin-face t nil))
      '("#\\\\?\\sw+"  (0 font-lock-constant-face nil t))
      '("(\\(declare\\|require\\)" . font-lock-keyword-face)
      )))
  "Gaudy expressions to highlight in Hen mode.")

(defconst hen-font-lock-keywords hen-font-lock-keywords-2)

(mapc (lambda (cell)
        (put (car cell) 'scheme-indent-function (cdr cell)))
      '((begin0 . 0) (begin-form . 0)

        (for-each . 1) (when . 1) (while . 1) (unless . 1)
        (and-let* . 1) (fluid-let . 1)

        (call-with-input-pipe . 1)
        (call-with-ouput-pipe . 1)
        (call-with-input-string . 1)
        (call-with-input-string . 1)

        (call-with-values . 1)

        (with-input-from-pipe . 1)
        (with-ouput-to-pipe . 0)
        (with-input-from-string . 1)
        (with-output-to-string . 0)

        (if* . 2)))

(defun hen-identifier-at-point ()
  "Return the identifier close to the cursor."
  (save-excursion
    (save-match-data
      (let ((beg (line-beginning-position))
            (end (line-end-position))
            (pos (point)))
      (cond ((progn (goto-char pos)
                    (skip-chars-forward " \t" end)
                    (skip-syntax-backward "w_" beg)
                    (memq (char-syntax (following-char)) '(?w ?_)))
             (buffer-substring-no-properties (point) (progn (forward-sexp 1) 
(point))))
            ((progn (goto-char pos)
                    (skip-chars-backward " \t" beg)
                    (skip-syntax-forward "w_" end)
                    (memq (char-syntax (preceding-char)) '(?w ?_)))
             (buffer-substring-no-properties (point) (progn (forward-sexp -1) 
(point))))
            (t nil))))))



(defun hen-build (cmd args)
  (compile-internal (mapconcat 'identity (cons cmd args) " ")
                    "No more errors" "csc" nil
                    `(("Error:.+in line \\([0-9]+\\):" 0 1 nil 
,(buffer-file-name)))
                    (lambda (ignored) "*csc*")))

(defun hen-build-unit ()
  (interactive)
  (let* ((file-name (file-name-nondirectory
                      (buffer-file-name)))
         (base-name (file-name-sans-extension file-name)))
    (hen-build "csc" (list "-s" file-name "-o" (concat base-name ".so")) )))

(defun hen-build-program ()
  (interactive)
  (let* ((file-name (file-name-nondirectory
                      (buffer-file-name)))
         (base-name (file-name-sans-extension file-name)))
    (hen-build "csc" (list file-name) )))

(define-derived-mode hen-mode scheme-mode "Hen"
  "Mode for editing chicken Scheme code.
\\[hen-complete-symbol] completes symbol base on the text at point.
\\[hen-csi-eval-last-sexp] evaluates the sexp at/preceding point in csi.
\\[hen-csi-eval-region] evaluates the region in csi.
\\[hen-csi-apropos] lists the csi's symbols matching a regex.
\\[hen-csi-send] reads a s-exp from the user and evaluates it csi.
\\[hen-describe-symbol] looks up info documentation for a symbol from.
the R5RS and Chicken info files.
\\[hen-build-unit] compiles the current file as a shared object
\\[hen-describe-symbol] compiles the current file as a program
"

  (set-syntax-table hen-syntax-table)
  (setq local-abbrev-table scheme-mode-abbrev-table)

  (define-key hen-mode-map (kbd "M-TAB")   'hen-complete-symbol)
  (define-key hen-mode-map (kbd "C-c C-e") 'hen-csi-eval-last-sexp)
  (define-key hen-mode-map (kbd "C-c C-r") 'hen-csi-eval-region)
  (define-key hen-mode-map (kbd "C-c C-a") 'hen-csi-apropos)
  (define-key hen-mode-map (kbd "C-c C-h") 'hen-describe-symbol)
  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
  (define-key hen-mode-map (kbd "C-c C-x") 'hen-csi-send)
  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
  (define-key hen-mode-map (kbd "C-c C-c") 'hen-build-program)

  (define-key hen-mode-map [menu-bar scheme run-scheme] nil)
  (define-key hen-mode-map [menu-bar shared build-prog] '("Compile File" 
hen-build-program))
  (define-key hen-mode-map [menu-bar shared send-to-csi] '("Evaluate" . 
hen-csi-send))
  (define-key hen-mode-map [menu-bar scheme build-as-unit] '("Compile File as 
Unit" . hen-build-unit))
  (define-key hen-mode-map [menu-bar scheme describe-sym] '("Lookup 
Documentation for Symbol" . hen-describe-symbol))
  (define-key hen-mode-map [menu-bar scheme apropos] '("Symbol Apropos" . 
hen-csi-apropos))
  (define-key hen-mode-map [menu-bar scheme eval-region] '("Eval Region" . 
hen-csi-eval-region))
  (define-key hen-mode-map [menu-bar scheme eval-last-sexp] '("Eval Last 
S-Expression" . hen-csi-eval-last-sexp))

  (setq font-lock-defaults
        '((hen-font-lock-keywords
           hen-font-lock-keywords-1 hen-font-lock-keywords-2)
          nil t (("+-*/.<>=!?$%_&~^:" . "w")) beginning-of-defun
          (font-lock-mark-block-function . mark-defun))))


;;stolen from cxref
(defun hen-looking-backward-at (regexp)
  "Return t if text before point matches regular expression REGEXP.
This function modifies the match data that `match-beginning',
`match-end' and `match-data' access; save and restore the match
data if you want to preserve them."
  (save-excursion
    (let ((here (point)))
      (if (re-search-backward regexp (point-min) t)
          (if (re-search-forward regexp here t)
              (= (point) here))))))

(defun hen-proc-wait-prompt (proc prompt-re &optional timeout msg)
  "Wait for the prompt of interactive process PROC. PROMPT-RE must be
a regexp matching the prompt. TIMEOUT is the amount of time to wait in
secs before giving up. MSG is the message to display while waiting."
  (setq timeout (if (numberp timeout) (* timeout 2) 60))
  (unless (stringp msg)
    (setq msg (concat "wait for "
                      (process-name proc)
                      "'s prompt")))
  (goto-char (process-mark proc))
  (accept-process-output proc 0 100000)
  (if (hen-looking-backward-at prompt-re)
      t
    (while (and (> timeout 0) (not (hen-looking-backward-at prompt-re)))
      (with-temp-message (setq msg (concat msg "."))
        (accept-process-output proc 0 500000))
      (setq timeout (1- timeout))
      (goto-char (process-mark proc)))
    (with-temp-message (concat msg (if (> timeout 0)
                                       " got it!" " timeout!"))
      (sit-for 0 100))
    (> timeout 0)))

(defun hen-proc-send (question proc prompt-re &optional timeout msg)
  "Send the string QUESTION to interactive process proc. PROMPT-RE is
the regexp matching PROC's prompt. TIMEOUT is the amount of time to
wait in secs before giving up. MSG is the message to display while
waiting."
  (setq timeout (if (numberp timeout) (* timeout 2) 60))
  (save-excursion
    (set-buffer (process-buffer proc))
    (widen)
    (save-match-data
      (when (hen-proc-wait-prompt proc prompt-re (/ timeout 2))
        (let ((start (match-end 0)))
          (narrow-to-region start (point-max))
          (process-send-string proc (concat question "\n"))
          (accept-process-output proc 0 500000)
          (hen-proc-wait-prompt proc prompt-re timeout msg)
          (narrow-to-region start (match-beginning 0))
          (current-buffer))))))

(defun hen-csi-buffer () (get-buffer-create " *csi*"))

(defun hen-csi-proc ()
  (let ((proc (get-buffer-process (hen-csi-buffer))))
    (if (and (processp proc)
             (eq (process-status proc) 'run))
        proc
      (setq proc (start-process "csi" (hen-csi-buffer) "csi"))
      (with-current-buffer (hen-csi-buffer)
        (accept-process-output proc)
        (hen-proc-wait-prompt proc "#;> ")
        (hen-proc-send "(require 'oblist)" proc "#;> ")
        proc))))

(defun hen-csi-send (sexp)
  "Evaluate SEXP in CSI"
  (interactive
   (let ((sexp (read-string "Evaluate S-expression: "))
         (send-sexp-p nil))
     (unwind-protect
         (progn
           (let ((obarray (make-vector 11 0)))
             (read sexp)
             (setq send-sexp-p t)))
       (unless send-sexp-p
         (setq send-sexp-p
               (y-or-n-p (format "`%s' is not a valid sexp! evaluate anyway? " 
sexp)))))
     (list (if send-sexp-p sexp nil))))
  (when (stringp sexp)
    (let* ((proc (hen-csi-proc))
           (buf (hen-proc-send (concat sexp "\n") proc "#;> "))
           result len)
      (unless (buffer-live-p buf)
        (error "Internal hen-mode failure"))

      (save-excursion
        (with-current-buffer buf
          (setq result (buffer-string))
          (setq len (length result))
          (if (and (> len 0)
                   (eq (aref result (1- len)) ?\n))
              (setq result (substring result 0 -1)))
          result)))))


(defun hen-csi-eval-region (beg end)
  "Evaluate the current region in CSI."
  (interactive "r")
  (message
   (hen-csi-send (buffer-substring beg end))))

(defun hen-csi-eval-last-sexp ()
  "Evaluate the s-expression at point in CSI"
  (interactive)
  (message
   (hen-csi-eval-region (save-excursion (backward-sexp) (point))
                        (point))))


(defun hen-csi-eval-definition ()
  "Evaluate the enclosing top-level form in CSI."
  (interactive)
  (save-excursion
    (message
     (hen-csi-eval-region (progn (beginning-of-defun) (point))
                          (progn (forward-sexp 1) (point))))))

(defun hen-complete-symbol (thing)
  "Complete symbol at point in Hen mode. THING is used as the prefix."
  (interactive (list (hen-identifier-at-point)))
  (let* ((matching-names-alist
          (read
           (hen-csi-send
            (concat "(pp (map list (delete-duplicates 
(##csi#name-of-symbols-starting-with \""
                    thing
                    "\"))))"))))
         (completion (try-completion thing matching-names-alist)))
    (cond ((eq completion t) nil)
          ((null completion)
           (error "Can't find completion for \"%s\"" thing))
          ((not (string= thing completion))
           (delete-region (progn (backward-sexp 1) (point))
                          (progn (forward-sexp 1) (point)))
           (insert completion))
          (t
           (message "Making completion list...")
           (with-output-to-temp-buffer "*Completions*"
             (display-completion-list
              (all-completions thing matching-names-alist)))))))


(defun hen-csi-try-complete (string ignore1 &optional ignore2)
  (let ((matches
         (read
          (hen-csi-send
           (concat "(pp (map list (delete-duplicates 
(##csi#name-of-symbols-starting-with \""
                   string
                   "\"))))")))))
    (cond ((null matches) nil)
          ((and (= (length matches) 1)
                (string-equal (caar matches) string))
           t)
          (t (try-completion string matches)))))

(defsubst hen-csi-symbol-completing-read (prompt)
  (list (completing-read prompt 'hen-csi-try-complete
                         nil nil (hen-identifier-at-point))))


(defun hen-describe-symbol (name)
  "Lookup documentation for symbol NAME."
  (interactive (hen-csi-symbol-completing-read "Describe symbol: "))
  (info-lookup-symbol name 'hen-mode) ;
  ;;(hen-lookup-info-doc name)
  )

(defun hen-csi-apropos (regex)
  "List the symbols matching REGEX."
  (interactive "sApropos (chicken's global symbols): ")
  (with-current-buffer (get-buffer-create "*Chicken Apropos*")
    (widen)
    (erase-buffer)
    (let* ((query (concat "(pp (map\n"
                          "  (lambda (sym) (cons (->string sym)\n"
                          "      (->string (if 
(##sys#symbol-has-toplevel-binding? sym)\n "
                          "                 (##sys#slot sym 0) '<unbound> 
))))\n"
                          "  (delete-duplicates! (##csi#symbols-matching \"" 
regex  "\"))))"))
           (results-alist (read (hen-csi-send query))))
      (if (display-mouse-p)
          (insert "If moving the mouse over text changes the text's color,\n"
                  (substitute-command-keys
                   "you can click \\[apropos-mouse-follow] on that text to get 
more information.\n")))
      (insert "In this buffer, go to the name of the command, or function,"
              " or variable,\n"
              (substitute-command-keys
               "and type \\[apropos-follow] to get full documentation.\n\n"))

      (dolist (item results-alist)
        (let ((name (car item))
              (obj (cdr item)))
          (insert (car item) " ")
          (add-text-properties (line-beginning-position) (1- (point))
                               `(item ,name action hen-describe-symbol
                                      face bold mouse-face highlight
                                      help-echo "mouse-2: display help on this 
item"))
          (indent-to-column 40)
          (insert (cdr item) "\n")))

      (apropos-mode)))
  (pop-to-buffer "*Chicken Apropos*" t))

(defconst hen-info-doc-list '("(r5rs)Index" "(chicken)Index"))

(defun hen-lookup-info-doc (topic)
  (let ((docs hen-info-doc-list)
        (pattern (format "\n\\* +\\([^\n:]*%s[^\n:]*\\):[ \t]*\\([^.\n]*\\)\\.[ 
\t]*\\([0-9]*\\)"
                         topic))
        doc node found)
    (while (and (consp docs) (not found))
      (setq doc (car docs)
            docs (cdr docs))
      (setq found (save-window-excursion
                    (save-excursion
                      (Info-goto-node doc)
                      (goto-char (point-min))
                      (re-search-forward pattern nil t)))))
    (if found
        (progn
          (pop-to-buffer "*info*")
          (hen-lookup-info-doc topic))
      (error "Can't find documentation for %s" topic))))


(info-lookup-add-help
 :mode 'hen-mode
 :regexp "[^()'\" \t\n]+"
 :ignore-case t
 ;; Aubrey Jaffer's rendition from <URL:ftp://ftp-swiss.ai.mit.edu/pub/scm>
 :doc-spec '(("(chicken)Index" nil
              "^[ \t]+- [^:\n]+:[ \t]*" "")
             ("(r5rs)Index" nil
              "^[ \t]+- [^:\n]+:[ \t]*" "")))

(provide 'hen)
(run-hooks 'hen-load-hook)
;;; HEN.EL ends here