path: root/geiser-chez.el

;;; geiser-chez.el -- Chez Scheme's implementation of the geiser protocols

;; Author: Peter <craven@gmx.net>
;; Maintainer:
;; Keywords: languages, chez, scheme, geiser
;; Homepage: https://gitlab.com/emacs-geiser/chez
;; Package-Requires: ((emacs "24.4") (geiser-core "1.0"))
;; SPDX-License-Identifier: BSD-3-Clause
;; Version: 0.1

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.


;;; Code:

(require 'geiser-connection)
(require 'geiser-syntax)
(require 'geiser-custom)
(require 'geiser-base)
(require 'geiser-eval)
(require 'geiser-edit)
(require 'geiser-log)
(require 'geiser)

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

(eval-when-compile (require 'cl-lib))


;;; Customization:

(defgroup geiser-chez nil
  "Customization for Geiser's Chez Scheme flavour."
  :group 'geiser)

(geiser-custom--defcustom geiser-chez-binary
    "scheme"
  "Name to use to call the Chez Scheme executable when starting a REPL."
  :type '(choice string (repeat string))
  :group 'geiser-chez)

(geiser-custom--defcustom geiser-chez-init-file "~/.chez-geiser"
  "Initialization file with user code for the Chez REPL."
  :type 'string
  :group 'geiser-chez)

(geiser-custom--defcustom geiser-chez-extra-command-line-parameters '()
  "Additional parameters to supply to the Chez binary."
  :type '(repeat string)
  :group 'geiser-chez)

(geiser-custom--defcustom geiser-chez-extra-keywords '()
  "Extra keywords highlighted in Chez Scheme buffers."
  :type '(repeat string)
  :group 'geiser-chez)


;;; REPL support:

(defun geiser-chez--binary ()
  (if (listp geiser-chez-binary)
      (car geiser-chez-binary)
    geiser-chez-binary))

(defvar geiser-chez-scheme-dir
  (expand-file-name "src" (file-name-directory load-file-name))
  "Directory where the Chez scheme geiser modules are installed.")

(defun geiser-chez--parameters ()
  "Return a list with all parameters needed to start Chez Scheme.
This function uses `geiser-chez-init-file' if it exists."
  (let ((init-file (and (stringp geiser-chez-init-file)
                        (expand-file-name geiser-chez-init-file))))
    `(,@(and init-file (file-readable-p init-file) (list init-file))
      ,(expand-file-name "geiser/geiser.ss" geiser-chez-scheme-dir)
      ,@geiser-chez-extra-command-line-parameters)))

(defconst geiser-chez--prompt-regexp "> ")


;;; Evaluation support:

(defun geiser-chez--geiser-procedure (proc &rest args)
  (cl-case proc
    ((eval compile)
     (let ((form (mapconcat 'identity (cdr args) " "))
           (module (cond ((string-equal "'()" (car args))
                          "'()")
                         ((and (car args))
                          (concat "'" (car args)))
                         (t
                          "#f"))))
       (format "(geiser:eval %s '%s)" module form)))
    ((load-file compile-file)
     (format "(geiser:load-file %s)" (car args)))
    ((no-values)
     "(geiser:no-values)")
    (t
     (let ((form (mapconcat 'identity args " ")))
       (format "(geiser:%s %s)" proc form)))))

(defun geiser-chez--get-module (&optional module)
  (cond ((null module)
         :f)
        ((listp module) module)
        ((stringp module)
         (condition-case nil
             (car (geiser-syntax--read-from-string module))
           (error :f)))
        (t :f)))

(defun geiser-chez--symbol-begin (module)
  (if module
      (max (save-excursion (beginning-of-line) (point))
           (save-excursion (skip-syntax-backward "^(>") (1- (point))))
    (save-excursion (skip-syntax-backward "^'-()>") (point))))

(defun geiser-chez--import-command (module)
  (format "(import %s)" module))

(defun geiser-chez--exit-command () "(exit 0)")
;; 
;; ;;; REPL startup

(defconst geiser-chez-minimum-version "9.4")

(defun geiser-chez--version (binary)
  (car (process-lines binary "--version")))

(defun geiser-chez--startup (remote)
  (let ((geiser-log-verbose-p t))
    (compilation-setup t)
    (geiser-eval--send/wait "(begin (import (geiser)) (write `((result ) (output . \"\"))) (newline))")))


;;; Error display:

(defun geiser-chez--display-error (module key msg)
  (when (stringp msg)
    (save-excursion (insert msg))
    (geiser-edit--buttonize-files))
  (and (or (eq key 'chez-error-message)
           (not key))
       (not (zerop (length msg)))
       msg))


;;; Keywords and syntax:

(defconst geiser-chez--builtin-keywords
  '("call-with-input-file"
    "call-with-output-file"
    "define-ftype"
    "define-structure"
    "exclusive-cond"
    "extend-syntax"
    "fluid-let"
    "fluid-let-syntax"
    "meta"
    "meta-cond"
    "record-case"
    "trace-case-lambda"
    "trace-define"
    "trace-define-syntax"
    "trace-do"
    "trace-lambda"
    "trace-let"
    "with"
    "with-implicit"
    "with-input-from-file"
    "with-input-from-string"
    "with-interrupts-disabled"
    "with-mutex"
    "with-output-to-file"
    "with-output-to-string"))

(defun geiser-chez--keywords ()
  (append
   (geiser-syntax--simple-keywords geiser-chez-extra-keywords)
   (geiser-syntax--simple-keywords geiser-chez--builtin-keywords)))

(geiser-syntax--scheme-indent
 (call-with-input-file 1)
 (call-with-output-file 1)
 (define-ftype 1)
 (struct 0)
 (union 0)
 (bits 0)
 (define-structure 1)
 (exclusive-cond 0)
 (extend-syntax 1)
 (fluid-let 1)
 (fluid-let-syntax 1)
 (meta 0)
 (meta-cond 0)
 (record-case 1)
 (trace-case-lambda 1)
 (trace-define 1)
 (trace-define-syntax 1)
 (trace-do 2)
 (trace-lambda 2)
 (trace-let 2)
 (with 1)
 (with-implicit 1)
 (with-input-from-file 1)
 (with-input-from-string 1)
 (with-interrupts-disabled 0)
 (with-mutex 1)
 (with-output-to-file 1)
 (with-output-to-string 0))


;;; Implementation definition:

(define-geiser-implementation chez
  (binary geiser-chez--binary)
  (arglist geiser-chez--parameters)
  (version-command geiser-chez--version)
  (minimum-version geiser-chez-minimum-version)
  (repl-startup geiser-chez--startup)
  (prompt-regexp geiser-chez--prompt-regexp)
  (debugger-prompt-regexp nil) ;; geiser-chez--debugger-prompt-regexp
  ;; (enter-debugger geiser-chez--enter-debugger)
  (marshall-procedure geiser-chez--geiser-procedure)
  (find-module geiser-chez--get-module)
  ;; (enter-command geiser-chez--enter-command)
  (exit-command geiser-chez--exit-command)
  (import-command geiser-chez--import-command)
  (find-symbol-begin geiser-chez--symbol-begin)
  (display-error geiser-chez--display-error)
  ;; (external-help geiser-chez--manual-look-up)
  ;; (check-buffer geiser-chez--guess)
  (keywords geiser-chez--keywords)
  ;; (case-sensitive geiser-chez-case-sensitive-p)
  )

(geiser-impl--add-to-alist 'regexp "\\.ss$" 'chez t)
(geiser-impl--add-to-alist 'regexp "\\.def$" 'chez t)

(provide 'geiser-chez)