;;; racket-repl.el

;; Copyright (c) 2013-2016 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Image portions Copyright (C) 2012 Jose Antonio Ortega Ruiz.

;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode

;; License:
;; 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 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. See
;; http://www.gnu.org/licenses/ for details.

(require 'racket-custom)
(require 'racket-common)
(require 'racket-util)
(require 'comint)
(require 'compile)
(require 'easymenu)

(defconst racket--repl-buffer-name/raw
  "Racket REPL"
  "The base buffer name, NOT surrounded in *stars*")
(defconst racket--repl-buffer-name
  (concat "*" racket--repl-buffer-name/raw "*")
  "The actual buffer name as created by comint-mode")

(defmacro with-racket-repl-buffer (&rest body)
  "Execute the forms in BODY with `racket-repl-mode' temporarily current.
The value returned is the value of the last form in BODY --
unless no `racket-repl-mode' buffer exists, in which case no BODY
forms are evaluated and nil is returned. See also
`with-current-buffer'."
  (declare (indent 0) (debug t))
  (let ((repl-buffer (make-symbol "repl-buffer")))
    `(let ((,repl-buffer (get-buffer racket--repl-buffer-name)))
       (when ,repl-buffer
         (with-current-buffer ,repl-buffer
           ,@body)))))

(defun racket--get-repl-buffer-process ()
  (get-buffer-process racket--repl-buffer-name))

(defun racket-repl--input-filter (str)
  "Don't save anything matching `racket-history-filter-regexp'."
  (not (string-match racket-history-filter-regexp str)))

(defun racket--get-old-input ()
  "Snarf the sexp ending at point."
  (if (looking-back comint-prompt-regexp (line-beginning-position))
      ""
    (save-excursion
      (let ((end (point)))
        (backward-sexp)
        (buffer-substring (point) end)))))

(defun racket-repl-eval-or-newline-and-indent ()
  "If complete sexpr, eval in Racket. Else do `racket-newline-and-indent'."
  (interactive)
  (let ((proc (get-buffer-process (current-buffer))))
    (cond ((not proc) (user-error "Current buffer has no process"))
          ((not (eq "" (racket--get-old-input)))
           (condition-case nil
               (let* ((beg (marker-position (process-mark proc)))
                      (end (save-excursion
                             (goto-char beg)
                             (forward-list) ;scan-error unless complete sexpr
                             (point))))
                 (comint-send-input)
                 ;; Remove comint-highlight-input face applied to
                 ;; input. I don't like how that looks.
                 (remove-text-properties beg end '(font-lock-face comint-highlight-input)))
             (scan-error (newline-and-indent)))))))

;;;###autoload
(defun racket-repl (&optional noselect)
  "Run the Racket REPL and display its buffer in some window.

If the Racket process is not already running, it is started.

If NOSELECT is not nil, does not select the REPL
window (preserves the originally selected window).

Commands that don't want the REPL to be displayed can instead use
`racket--repl-ensure-buffer-and-process'."
  (interactive "P")
  (racket--repl-ensure-buffer-and-process t)
  (unless noselect
    (select-window (get-buffer-window racket--repl-buffer-name t))))

(defconst racket--minimum-required-version "6.0"
  "The minimum version of Racket required by run.rkt.

Although some functionality may require an even newer version of
Racket, run.rkt will handle that via `dynamic-require` and
fallbacks. The version number here is a baseline for run.rkt to
be able to load at all.")

(defvar racket--run.rkt
  (expand-file-name "run.rkt"
                    (file-name-directory (or load-file-name
                                             (racket--buffer-file-name))))
  "Path to run.rkt")

(defun racket--repl-live-p ()
  "Does the Racket REPL buffer exist and have a live Racket process?"
  (comint-check-proc racket--repl-buffer-name))

(defun racket--repl-ensure-buffer-and-process (&optional display)
  "Ensure Racket REPL buffer exists and has live Racket process.

If the Racket process is not already running, it is started and
the buffer is put in `racket-repl-mode'.

Non-nil DISPLAY means `display-buffer'.

Never changes selected window."
  (if (comint-check-proc racket--repl-buffer-name)
      (when display
        (display-buffer racket--repl-buffer-name))
    (racket--require-version racket--minimum-required-version)
    (with-current-buffer
        (with-temp-message "Starting Racket process..."
         (make-comint racket--repl-buffer-name/raw ;w/o *stars*
                      racket-program
                      nil
                      racket--run.rkt
                      (number-to-string racket-command-port)))
      ;; Display now so users see startup and banner sooner.
      (when display
        (display-buffer (current-buffer)))
      ;; The following is needed to make e.g. λ work when pasted
      ;; into the comint-buffer, both directly by the user and via
      ;; the racket--repl-eval functions.
      (set-process-coding-system (get-buffer-process racket--repl-buffer-name)
                                 'utf-8 'utf-8)
      (racket-repl-mode)
      (racket--repl-command-connect))))

(defun racket--version ()
  "Get the `racket-program' version as a string."
  (with-temp-message "Checking Racket version..."
    (with-temp-buffer
      (call-process racket-program
                    nil                  ;infile: none
                    t                    ;destination: current-buffer
                    nil                  ;redisplay: no
                    "-e"
                    "(version)")
      (eval (read (buffer-substring (point-min) (point-max)))))))

(defun racket--require-version (at-least)
  "Raise a `user-error' unless Racket is version AT-LEAST."
  (let ((have (racket--version)))
    (unless (version<= at-least have)
      (user-error "racket-mode requires at least Racket version %s but you have %s"
                  at-least have))
    t))

(defvar racket--repl-command-process nil)
(defvar racket--repl-command-connect-timeout 30)

(defun racket--repl-command-connect ()
  "Connect to the Racket command process.
If already connected, disconnects then connects again."
  (racket--repl-command-disconnect)
  (with-temp-message "Connecting to command process..."
    ;; The command server may not be ready -- Racket itself and our
    ;; backend are still starting up -- so retry until timeout.
    (with-timeout (racket--repl-command-connect-timeout
                   (error "Could not connect to command process"))
      (while (not racket--repl-command-process)
        (condition-case ()
            (setq racket--repl-command-process
                  (let ((process-connection-type nil)) ;use pipe not pty
                    (open-network-stream "racket-command"
                                         (get-buffer-create "*racket-command-output*")
                                         "127.0.0.1"
                                         racket-command-port)))
          (error (sit-for 0.1)))))))

(defun racket--repl-command-disconnect ()
  "Disconnect from the Racket command process."
  (when racket--repl-command-process
    (with-temp-message "Deleting existing connection to command process..."
      (delete-process racket--repl-command-process)
      (setq racket--repl-command-process nil))))

(defun racket--repl-command (fmt &rest xs)
  "Send command to the Racket process and return the response sexp.
Do not prefix the command with a `,'. Not necessary to append \n."
  (racket--repl-ensure-buffer-and-process)
  (let ((proc racket--repl-command-process))
    (unless proc
      (error "Command process is nil"))
    (with-current-buffer (process-buffer proc)
      (delete-region (point-min) (point-max))
      (process-send-string proc
                           (concat (apply #'format (cons fmt xs))
                                   "\n"))
      (with-timeout (racket-command-timeout
                     (error "Command process timeout"))
        ;; While command server running and not yet complete sexp
        (while (and (memq (process-status proc) '(open run))
                    (or (= (point) (point-min))
                        (condition-case ()
                            (progn (scan-lists (point-min) 1 0) nil)
                          (scan-error t))))
          (accept-process-output nil 0.1)))
      (cond ((not (memq (process-status proc) '(open run)))
             (error "Racket command process: died"))
            ((= (point-min) (point))
             (error "Racket command process: Empty response"))
            (t
             (let ((result (buffer-substring (point-min) (point-max))))
               (delete-region (point-min) (point-max))
               (eval (read result))))))))

(defun racket-repl-file-name ()
  "Return the file running in the buffer, or nil.

The result can be nil if the REPL is not started, or if it is
running no particular file as with the `,top` command.

On Windows this will replace \ with / in an effort to match the
Unix style names used by Emacs on Windows."
  (when (comint-check-proc racket--repl-buffer-name)
    (let ((path (racket--repl-command "path")))
      (and path
           (cl-case system-type
             (windows-nt (subst-char-in-string ?\\ ?/ path))
             (otherwise  path))))))

(defun racket--in-repl-or-its-file-p ()
  "Is current-buffer `racket-repl-mode' or buffer for file active in it?"
  (or (eq (current-buffer)
          (get-buffer racket--repl-buffer-name))
      (string-equal (racket--buffer-file-name)
                    (racket-repl-file-name))))

(defun racket-repl-switch-to-edit ()
  "Switch to the window for the buffer of the file running in the REPL.

If no buffer is visting the file, `find-file' it in `other-window'.

If the REPL is running no file -- if the prompt is `>` -- use the
most recent `racket-mode' buffer, if any."
  (interactive)
  (let ((path (racket-repl-file-name)))
    (if path
        (let ((buffer (find-buffer-visiting path)))
          (if buffer
              (pop-to-buffer buffer t)
            (other-window 1)
            (find-file path)))
      (let ((buffer (racket--most-recent-racket-mode-buffer)))
        (unless buffer
          (user-error "There are no racket-mode buffers"))
        (pop-to-buffer buffer t)))))

(defun racket--most-recent-racket-mode-buffer ()
  (cl-some (lambda (b)
             (with-current-buffer b
               (and (eq major-mode 'racket-mode) b)))
           (buffer-list)))

(defun racket--repl-eval (fmt &rest vs)
  "Eval expression in the *Racket REPL* buffer.
Allow Racket process output to be displayed, and show the window.
Intended for use by things like ,run command."
  (racket-repl t)
  (racket--repl-forget-errors)
  (comint-send-string (racket--get-repl-buffer-process)
                      (apply #'format (cons fmt vs)))
  (racket--repl-show-and-move-to-end))

;;; send to REPL

(defun racket--send-region-to-repl (start end)
  "Internal function to send the region to the Racket REPL.

Before sending the region, call `racket-repl' and
`racket--repl-forget-errors'. Also insert a ?\n at the process
mark so that output goes on a fresh line, not on the same line as
the prompt.

Afterwards call `racket--repl-show-and-move-to-end'."
  (when (and start end)
    (racket-repl t)
    (racket--repl-forget-errors)
    (let ((proc (racket--get-repl-buffer-process)))
      (with-racket-repl-buffer
        (save-excursion
          (goto-char (process-mark proc))
          (insert ?\n)
          (set-marker (process-mark proc) (point))))
      (comint-send-region proc start end)
      (comint-send-string proc "\n"))
    (racket--repl-show-and-move-to-end)))

(defun racket-send-region (start end)
  "Send the current region (if any) to the Racket REPL."
  (interactive "r")
  (unless (region-active-p)
    (user-error "No region"))
  (racket--send-region-to-repl start end))

(defun racket-send-definition ()
  "Send the current definition to the Racket REPL."
  (interactive)
  (save-excursion
   (end-of-defun)
   (let ((end (point)))
     (beginning-of-defun)
     (racket--send-region-to-repl (point) end))))

(defun racket-send-last-sexp ()
  "Send the previous sexp to the Racket REPL.

When the previous sexp is a sexp comment the sexp itself is sent,
without the #; prefix."
  (interactive)
  (racket--send-region-to-repl (save-excursion
                                 (backward-sexp)
                                 (if (save-match-data (looking-at "#;"))
                                     (+ (point) 2)
                                   (point)))
                               (point)))

(defun racket--repl-forget-errors ()
  "Forget existing errors in the REPL.

Although they remain clickable they will be ignored by
`next-error' and `previous-error'"
  (with-racket-repl-buffer
    (compilation-forget-errors)
    ;; `compilation-forget-errors' may have just set
    ;; `compilation-messages-start' to a marker at position 1. But in
    ;; that case process output (including error messages) will be
    ;; inserted ABOVE the marker, in which case `next-error' won't see
    ;; them. Instead use a non-marker position like 1 or use nil.
    (when (and (markerp compilation-messages-start)
               (equal (marker-position compilation-messages-start) 1)
               (equal (marker-buffer compilation-messages-start) (current-buffer)))
      (setq compilation-messages-start nil))))

(defun racket--repl-show-and-move-to-end ()
  "Make the Racket REPL visible, and move point to end.
Keep original window selected."
  (display-buffer racket--repl-buffer-name)
  (save-selected-window
    (select-window (get-buffer-window racket--repl-buffer-name t))
    (comint-show-maximum-output)))

;;; Inline images in REPL

(defvar racket-image-cache-dir nil)

(defun racket-repl--list-image-cache ()
  "List all the images in the image cache."
  (and racket-image-cache-dir
       (file-directory-p racket-image-cache-dir)
       (let ((files (directory-files-and-attributes
                     racket-image-cache-dir t "racket-image-[0-9]*.png")))
         (mapcar 'car
                 (sort files (lambda (a b)
                               (< (float-time (nth 6 a))
                                  (float-time (nth 6 b)))))))))

(defun racket-repl--clean-image-cache ()
  "Clean all except for the last `racket-images-keep-last'
images in 'racket-image-cache-dir'."
  (interactive)
  (dolist (file (butlast (racket-repl--list-image-cache)
                         racket-images-keep-last))
    (delete-file file)))

(defun racket-repl--replace-images ()
  "Replace all image patterns with actual images"
  (with-silent-modifications
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward  "\"#<Image: \\(.+racket-image-.+\\.png\\)>\"" nil t)
        ;; can't pass a filename to create-image because emacs might
        ;; not display it before it gets deleted (race condition)
        (let* ((file (match-string 1))
               (begin (match-beginning 0))
               (end (match-end 0)))
          (delete-region begin end)
          (goto-char begin)
          (if (and racket-images-inline (display-images-p))
              (insert-image (create-image file) "[image]")
            (goto-char begin)
            (insert "[image] ; use M-x racket-view-last-image to view"))
          (setq racket-image-cache-dir (file-name-directory file))
          (racket-repl--clean-image-cache))))))

(defun racket-view-last-image (n)
  "Open the last displayed image using `racket-images-system-viewer'.

With prefix arg, open the N-th last shown image."
  (interactive "p")
  (let ((images (reverse (racket-repl--list-image-cache))))
    (if (>= (length images) n)
        (start-process "Racket image view"
                       nil
                       racket-images-system-viewer
                       (nth (- n 1) images))
      (error "There aren't %d recent images" n))))

(defun racket-repl--output-filter (txt)
  (racket-repl--replace-images))

;;; racket-repl-mode

(defvar racket-repl-mode-map
  (racket--easy-keymap-define
   '(("RET"             racket-repl-eval-or-newline-and-indent)
     ("TAB"             indent-for-tab-command)
     ("M-C-u"           racket-backward-up-list)
     ("C-a"             comint-bol)
     ("C-w"             comint-kill-region)
     ("[C-S-backspace]" comint-kill-whole-line)
     ("["               racket-smart-open-bracket)
     (")"               racket-insert-closing)
     ("]"               racket-insert-closing)
     ("}"               racket-insert-closing)
     ("C-c C-e x"       racket-expand-definition)
     ("C-c C-e e"       racket-expand-last-sexp)
     ("C-c C-e r"       racket-expand-region)
     ("C-c C-e a"       racket-expand-again)
     ("M-C-y"           racket-insert-lambda)
     ("C-c C-d"         racket-doc)
     ("C-c C-."         racket-describe)
     ("M-."             racket-visit-definition)
     ("C-M-."           racket-visit-module)
     ("M-,"             racket-unvisit)
     ("C-c C-z"         racket-repl-switch-to-edit)
     ("C-c C-l"         racket-logger)))
  "Keymap for Racket REPL mode.")

(easy-menu-define racket-repl-mode-menu racket-repl-mode-map
  "Menu for Racket REPL mode."
  '("Racket"
    ["Insert Lambda" racket-insert-lambda] ;λ in string breaks menu
    ["Indent Region" indent-region]
    ["Cycle Paren Shapes" racket-cycle-paren-shapes]
    ("Macro Expand"
     ["Region" racket-expand-region  :active (region-active-p)]
     ["Definition" racket-expand-definition]
     ["Last S-Expression" racket-expand-last-sexp]
     "---"
     ["Again" racket-expand-again])
    "---"
    ["Visit Definition" racket-visit-definition]
    ["Visit Module" racket-visit-module]
    ["Return from Visit" racket-unvisit]
    "---"
    ["Racket Documentation" racket-doc]
    ["Describe" racket-describe]
    "---"
    ["Switch to Edit Buffer" racket-repl-switch-to-edit]))

(define-derived-mode racket-repl-mode comint-mode "Racket-REPL"
  "Major mode for Racket REPL.
\\{racket-repl-mode-map}"
  (racket--common-variables)
  (setq-local comint-prompt-regexp (rx (regexp "^[^>\n]*") "\ufeff> "))
  (setq-local comint-use-prompt-regexp t)
  (setq-local comint-prompt-read-only nil)
  (setq-local mode-line-process nil)
  (setq-local comint-input-filter #'racket-repl--input-filter)
  (add-hook 'comint-output-filter-functions #'racket-repl--output-filter nil t)
  (compilation-setup t)
  (setq-local
   compilation-error-regexp-alist
   '(;; error
     ("^;?[ ]*\\([^ :]+\\):\\([0-9]+\\)[:.]\\([0-9]+\\)" 1 2 3)
     ;; contract
     ("^;?[ ]*at:[ ]+\\([^ :]+\\):\\([0-9]+\\)[.]\\([0-9]+\\)$" 1 2 3)
     ;; rackunit check-xxx
     ("#<path:\\([^>]+\\)> \\([0-9]+\\) \\([0-9]+\\)" 1 2 3)
     ;;rackunit/text-ui test-suite
     ("^location:[ ]+\\(\\([^:]+\\):\\([0-9]+\\):\\([0-9]+\\)\\)" 2 3 4 2 1)
     ;; path struct
     ("#<path:\\([^>]+\\)>" 1 nil nil 0)
     ))
  (setq-local comint-get-old-input #'racket--get-old-input))

(provide 'racket-repl)

;; racket-repl.el ends here
