;;; racket-edit.el -*- lexical-binding: t -*-

;; Copyright (c) 2013-2018 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.

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

;; racket-mode per se, i.e. the .rkt file buffers

(require 'cl-lib)
(require 'cl-macs)
(require 'racket-custom)
(require 'racket-common)
(require 'racket-complete)
(require 'racket-util)
(require 'hideshow)
(require 'tooltip)

(defun racket-run (&optional prefix)
  "Save and evaluate the buffer in REPL.

With one C-u prefix, uses errortrace for improved stack traces.
Otherwise follows the `racket-error-context' setting.

With two C-u prefixes, instruments code for step debugging. See
`racket-debug-mode' and the variable `racket-debuggable-files'.

If point is within a Racket module form, the REPL \"enters\" that
submodule (uses its language info and namespace).

When you run again, the file is evaluated from scratch --- the
custodian releases resources like threads and the evaluation
environment is reset to the contents of the file. In other words,
like DrRacket, this provides the predictability of a \"static\"
baseline, plus the ability to explore interactively using the
REPL.

See also `racket-run-and-switch-to-repl', which is even more like
DrRacket's Run because it selects the REPL window (gives it the
focus), too.

When `racket-retry-as-skeleton' is true, if your source file has
an error, a \"skeleton\" of your file is evaluated to get
identifiers from module languages, require forms, and
definitions. That way, things like completion and
`racket-describe' are more likely to work while you edit the file
to fix the error. If not even the \"skeleton\" evaluation
succeeds, you'll have only identifiers provided by racket/base,
until you fix the error and run again.

Output in the Racket REPL buffer that describes a file and
position is automatically \"linkified\". Examples of such text
include:

- Racket error messages.
- rackunit test failure location messages.
- print representation of path objects.

To visit these locations, move point there and press RET or mouse
click. Or, use the standard `next-error' and `previous-error'
commands."
  (interactive "P")
  (racket--repl-run (racket--what-to-run)
                    (pcase prefix
                      (`(4)  'high)
                      (`(16) 'debug)
                      (_     racket-error-context))))

(defun racket-run-with-errortrace ()
  "Run with `racket-error-context' temporarily set to \"high\".
This is just `racket-run' with a C-u prefix. Defined as a function so
it can be a menu target."
  (interactive)
  (racket-run '(4)))

(defun racket-run-with-debugging ()
  "Run with `racket-error-context' temporarily set to 'debug.
This is just `racket-run' with a double C-u prefix. Defined as a
function so it can be a menu target."
  (interactive)
  (racket-run '(16)))

(defun racket-run-and-switch-to-repl (&optional prefix)
  "This is `racket-run' followed by `racket-repl'."
  (interactive "P")
  (racket-run prefix)
  (racket-repl))

(defun racket-racket ()
  "Do \"racket <file>\" in a shell buffer."
  (interactive)
  (racket--shell (concat (shell-quote-argument racket-program)
                         " "
                         (shell-quote-argument (racket--buffer-file-name)))))

(defun racket-test (&optional coverage)
  "Run the \"test\" submodule.

With prefix, runs with coverage instrumentation and highlights
uncovered code.

Put your tests in a \"test\" submodule. For example:

#+BEGIN_SRC racket
    (module+ test
      (require rackunit)
      (check-true #t))
#+END_SRC

Any rackunit test failure messages show the location. You may use
`next-error' to jump to the location of each failing test.

See also:
- `racket-fold-all-tests'
- `racket-unfold-all-tests'
"
  (interactive "P")
  (let ((mod-path (list 'submod (racket--buffer-file-name) 'test))
        (buf (current-buffer)))
    (if (not coverage)
        (racket--repl-run mod-path)
      (message "Running test submodule with coverage instrumentation...")
      (racket--repl-run
       mod-path
       'coverage
       (lambda (_n/a)
         (message "Getting coverage results...")
         (racket--cmd/async
          `(get-uncovered)
          (lambda (xs)
            (pcase xs
              (`() (message "Full coverage."))
              ((and xs `((,beg0 . ,_) . ,_))
               (message "Missing coverage in %s place(s)." (length xs))
               (with-current-buffer buf
                 (dolist (x xs)
                   (let ((o (make-overlay (car x) (cdr x) buf)))
                     (overlay-put o 'name 'racket-uncovered-overlay)
                     (overlay-put o 'priority 100)
                     (overlay-put o 'face font-lock-warning-face)))
                 (goto-char beg0)))))))))))

(add-hook 'racket--repl-before-run-hook #'racket--remove-coverage-overlays)

(defun racket--remove-coverage-overlays ()
  (remove-overlays (point-min) (point-max) 'name 'racket-uncovered-overlay))

(defun racket-raco-test ()
  "Do \"raco test -x <file>\" in a shell buffer to run the \"test\" submodule."
  (interactive)
  (racket--shell (concat (shell-quote-argument racket-program)
                         " -l raco test -x "
                         (shell-quote-argument (racket--buffer-file-name)))))

(defun racket--shell (cmd)
  (racket--save-if-changed)
  (let ((w (selected-window)))
    (pcase (get-buffer-window "*shell*" t)
      (`() (other-window -1))
      (win (select-window win)))
    (with-temp-message cmd
      (shell)
      (pop-to-buffer-same-window "*shell*")
      (comint-send-string "*shell*" (concat cmd "\n"))
      (select-window w)
      (sit-for 3))))

;;; visiting defs and mods

(defun racket-visit-definition (&optional prefix)
  "Visit definition of identifier at point.

If there is no identifier at point, prompt for it.

With a prefix, always prompt for the identifier.

Use `racket-unvisit' to return.

Please keep in mind the following limitations:

- Only finds symbols defined in the current namespace. You may
  need to `racket-run' the current buffer, first.

- Only visits the definition of module-level identifiers --
  things for which Racket's \"identifier-binding\" function
  returns information. This does NOT include things such as
  local (nested) function definitions or \"racket/class\" member
  functions. To find those in the same file, you'll need to use a
  normal Emacs text search function like `isearch-forward'.

- If the definition is found in Racket's \"#%kernel\" module, it
  will tell you so but won't visit the definition site."
  (interactive "P")
  (pcase (racket--symbol-at-point-or-prompt prefix "Visit definition of: ")
    (`nil nil)
    (str (racket--visit-symbol-definition str))))

(defun racket-lispy-visit-symbol-definition (str)
  "Function called by lispy.el's `lispy-goto-symbol' for Racket
symbol definition lookup."
  (racket--visit-symbol-definition str))

(defun racket--visit-symbol-definition (str)
  (if (and (eq major-mode 'racket-mode)
           (not (equal (racket--repl-file-name+md5)
                       (cons (racket--buffer-file-name t) (md5 (current-buffer)))))
           (y-or-n-p "Run current buffer first? "))
      (racket--repl-run nil nil
                        (lambda (_n/a)
                          (racket--do-visit-def-or-mod 'def str)))
    (racket--do-visit-def-or-mod 'def str)))

(defun racket-visit-module (&optional prefix)
  "Visit definition of module at point, e.g. net/url or \"file.rkt\".

If there is no module at point, prompt for it.

With a prefix, always prompt for the module.

Use `racket-unvisit' to return.

See also: `racket-find-collection'."
  (interactive "P")
  (let* ((v (racket--module-at-point))
         (v (if (or prefix (not v))
                (read-from-minibuffer "Visit module: " (or v ""))
              v)))
    ;; If the module name is quoted e.g. "file.rkt", just do
    ;; equivalent of `find-file-at-point'. Else ask back-end.
    (cond ((and (equal "\"" (substring v 0 1))
                (equal "\"" (substring v -1 nil)))
           (racket--push-loc)
           (find-file (expand-file-name (substring v 1 -1)))
           (message "Type M-, to return"))
          (t (racket--do-visit-def-or-mod 'mod v)))))

(defun racket--module-at-point ()
  "Treat point as a Racket module path name, possibly in a multi-in form."
  ;; `thing-at-point' 'filename matches both net/url and "file.rkt".
  ;; But. 1. Returns both without the quotes; use `syntax-ppss' to
  ;; detect latter (string). 2. Returns nil if on the opening quote;
  ;; use `forward-char' then.
  (save-excursion
    (when (eq ?\" (char-syntax (char-after))) ;2
      (forward-char))
    (pcase (racket--thing-at-point 'filename t)
      (`() `())
      (v
       (let* ((ppss       (syntax-ppss))
              (relative-p (and (racket--ppss-string-p ppss) t)) ;1
              (multi-in   (condition-case ()
                              (progn
                                (when relative-p
                                  (goto-char (racket--ppss-string/comment-start ppss)))
                                (backward-up-list 1)
                                (backward-sexp 2)
                                (when (looking-at-p "multi-in")
                                  (forward-sexp 2)
                                  (backward-sexp 1)
                                  (when (eq ?\" (char-syntax (char-after))) ;2
                                    (forward-char))
                                  (unless (eq relative-p
                                              (and (racket--ppss-string-p ppss) t)) ;1
                                    (user-error "multi-in mixes absolute and relative paths"))
                                  (racket--thing-at-point 'filename t)))
                            (scan-error nil))))
         (concat (if relative-p "\"" "") ;1
                 (if multi-in
                     (concat multi-in "/")
                   "")
                 v
                 (if relative-p "\"" ""))))))) ;1

(defun racket--do-visit-def-or-mod (cmd str)
  "CMD must be 'def or 'mod. STR must be stringp."
  (unless (memq major-mode '(racket-mode racket-repl-mode racket-describe-mode))
    (user-error "That doesn't work in %s" major-mode))
  (pcase (racket--cmd/await (list cmd str))
    (`(,path ,line ,col)
     (racket--push-loc)
     (find-file (funcall racket-path-from-racket-to-emacs-function path))
     (goto-char (point-min))
     (forward-line (1- line))
     (forward-char col)
     (message "Type M-, to return"))
    (`kernel
     (message "`%s' defined in #%%kernel -- source not available." str))
    (_
     (message "Not found."))))

(defvar racket--loc-stack '())

(defun racket--push-loc ()
  (push (cons (current-buffer) (point))
        racket--loc-stack))

(defun racket-unvisit ()
  "Return from previous `racket-visit-definition' or `racket-visit-module'."
  (interactive)
  (if racket--loc-stack
      (pcase (pop racket--loc-stack)
        (`(,buffer . ,pt)
         (pop-to-buffer-same-window buffer)
         (goto-char pt)))
    (message "Stack empty.")))

(defun racket-doc (&optional prefix)
  "View documentation of the identifier or string at point.

Uses the default external web browser.

If point is an identifier required in the current namespace that
has help, opens the web browser directly at that help
topic. (i.e. Uses the identifier variant of racket/help.)

Otherwise, opens the 'search for a term' page, where you can
choose among multiple possibilities. (i.e. Uses the string
variant of racket/help.)

With a C-u prefix, prompts for the identifier or quoted string,
instead of looking at point."
  (interactive "P")
  (pcase (racket--symbol-at-point-or-prompt prefix "Racket help for: ")
    (`nil nil)
    (str (racket--cmd/async `(doc ,str)))))

;;; code folding

;;;###autoload
(add-to-list 'hs-special-modes-alist
             '(racket-mode "(" ")" ";" nil nil))

(defun racket--for-all-tests (verb f)
  (save-excursion
    (goto-char (point-min))
    (let ((n 0))
      (while (re-search-forward "^(module[+*]? test" (point-max) t)
        (funcall f)
        (cl-incf n)
        (goto-char (match-end 0)))
      (message "%s %d test submodules" verb n))))

(defun racket-fold-all-tests ()
  "Fold (hide) all test submodules."
  (interactive)
  (racket--for-all-tests "Folded" 'hs-hide-block))

(defun racket-unfold-all-tests ()
  "Unfold (show) all test submodules."
  (interactive)
  (racket--for-all-tests "Unfolded" 'hs-show-block))

;;; requires

(defun racket-tidy-requires ()
  "Make a single top-level \"require\" form, modules sorted, one per line.

All top-level require forms are combined into a single form.
Within that form:

- A single subform is used for each phase level, sorted in this
  order: for-syntax, for-template, for-label, for-meta, and
  plain (phase 0).

  - Within each level subform, the modules are sorted:

    - Collection path modules -- sorted alphabetically.

    - Subforms such as only-in.

    - Quoted relative requires -- sorted alphabetically.

At most one module is listed per line.

Note: This only works for requires at the top level of a source
file using #lang. It does NOT work for require forms inside
module forms.

See also: `racket-trim-requires' and `racket-base-requires'."
  (interactive)
  (unless (eq major-mode 'racket-mode)
    (user-error "Current buffer is not a racket-mode buffer"))
  (pcase (racket--top-level-requires 'find)
    (`nil (user-error "The file module has no requires; nothing to do"))
    (reqs (pcase (racket--cmd/await `(requires/tidy ,reqs))
            ("" nil)
            (new (goto-char (racket--top-level-requires 'kill))
                 (insert (concat new "\n")))))))

(defun racket-trim-requires ()
  "Like `racket-tidy-requires' but also deletes unnecessary requires.

Note: This only works when the source file can be evaluated with
no errors.

Note: This only works for requires at the top level of a source
file using #lang. It does NOT work for require forms inside
module forms. Furthermore, it is not smart about module+ or
module* forms -- it might delete top level requires that are
actually needed by such submodules.

See also: `racket-base-requires'."
  (interactive)
  (unless (eq major-mode 'racket-mode)
    (user-error "Current buffer is not a racket-mode buffer"))
  (when (racket--ok-with-module+*)
   (racket--save-if-changed)
   (pcase (racket--top-level-requires 'find)
     (`nil (user-error "The file module has no requires; nothing to do"))
     (reqs (pcase (racket--cmd/await `(requires/trim
                                       ,(racket--buffer-file-name)
                                       ,reqs))
             (`nil (user-error "Syntax error in source file"))
             (""   (goto-char (racket--top-level-requires 'kill)))
             (new  (goto-char (racket--top-level-requires 'kill))
                   (insert (concat new "\n"))))))))

(defun racket-base-requires ()
  "Change from \"#lang racket\" to \"#lang racket/base\".

Adds explicit requires for imports that are provided by
\"racket\" but not by \"racket/base\".

This is a recommended optimization for Racket applications.
Avoiding loading all of \"racket\" can reduce load time and
memory footprint.

Also, as does `racket-trim-requires', this removes unneeded
modules and tidies everything into a single, sorted require form.

Note: This only works when the source file can be evaluated with
no errors.

Note: This only works for requires at the top level of a source
file using #lang. It does NOT work for require forms inside
module forms. Furthermore, it is not smart about module+ or
module* forms -- it might delete top level requires that are
actually needed by such submodules.

Note: Currently this only helps change \"#lang racket\" to
\"#lang racket/base\". It does not help with other similar
conversions, such as changing \"#lang typed/racket\" to \"#lang
typed/racket/base\"."
  (interactive)
  (unless (eq major-mode 'racket-mode)
    (user-error "Current buffer is not a racket-mode buffer"))
  (when (racket--buffer-start-re "^#lang.*? racket/base$")
    (user-error "Already using #lang racket/base. Nothing to change."))
  (unless (racket--buffer-start-re "^#lang.*? racket$")
    (user-error "File does not use use #lang racket. Cannot change."))
  (when (racket--ok-with-module+*)
    (racket--save-if-changed)
    (let ((reqs (racket--top-level-requires 'find)))
      (pcase (racket--cmd/await `(requires/base
                                  ,(racket--buffer-file-name)
                                  ,reqs))
        (`nil (user-error "Syntax error in source file"))
        (new (goto-char (point-min))
             (re-search-forward "^#lang.*? racket$")
             (insert "/base")
             (goto-char (or (racket--top-level-requires 'kill)
                            (progn (insert "\n\n") (point))))
             (unless (string= "" new)
               (insert (concat new "\n"))))))))

(defun racket--ok-with-module+* ()
  (save-excursion
    (goto-char (point-min))
    (or (not (re-search-forward (rx ?\( "module" (or "+" "*")) nil t))
        (prog1
            (y-or-n-p "Analysis will be unreliable due to module+ or module* forms -- proceed anyway? ")
          (message "")))))

(defun racket--buffer-start-re (re)
  (save-excursion
    (ignore-errors
      (goto-char (point-min))
      (re-search-forward re)
      t)))

(defun racket--top-level-requires (what)
  "Identify all top-level requires and do WHAT.

When WHAT is 'find, returns the top-level require forms.

When WHAT is 'kill, kill the top-level requires, returning the
location of the first one."
  (save-excursion
    (goto-char (point-min))
    (let ((first-beg nil)
          (requires nil))
      (while (re-search-forward "^(require " nil t)
        (let* ((beg (progn (up-list -1)   (point)))
               (end (progn (forward-sexp) (point)))
               (str (buffer-substring-no-properties beg end))
               (sexpr (read str)))
          (unless first-beg (setq first-beg beg))
          (setq requires (cons sexpr requires))
          (when (eq 'kill what)
            (kill-sexp -1)
            (delete-blank-lines))))
      (if (eq 'kill what) first-beg requires))))

;;; racket-check-syntax

(defvar racket--highlight-overlays nil)

(defun racket--highlight (beg end defp)
  ;; Unless one of our highlight overlays already exists there...
  (let ((os (overlays-at beg)))
    (unless (cl-some (lambda (o) (member o racket--highlight-overlays)) os)
      (let ((o (make-overlay beg end)))
        (setq racket--highlight-overlays (cons o racket--highlight-overlays))
        (overlay-put o 'name 'racket-check-syntax-overlay)
        (overlay-put o 'priority 100)
        (overlay-put o 'face (if defp
                                 racket-check-syntax-def-face
                               racket-check-syntax-use-face))))))

(defun racket--unhighlight-all ()
  (while racket--highlight-overlays
    (delete-overlay (car racket--highlight-overlays))
    (setq racket--highlight-overlays (cdr racket--highlight-overlays))))

(defun racket--non-empty-string-p (v)
  (and (stringp v)
       (not (string-match-p "\\`[ \t\n\r]*\\'" v)))) ;`string-blank-p'

(defun racket--point-entered (_old new)
  (pcase (get-text-property new 'help-echo)
    ((and s (pred racket--non-empty-string-p))
     (if (and (boundp 'tooltip-mode)
              tooltip-mode
              (fboundp 'window-absolute-pixel-position))
         (pcase (window-absolute-pixel-position new)
           (`(,left . ,top)
            (let ((tooltip-frame-parameters `((left . ,left)
                                              (top . ,top)
                                              ,@tooltip-frame-parameters)))
              (tooltip-show s))))
       (message "%s" s))))
  (pcase (get-text-property new 'racket-check-syntax-def)
    ((and uses `((,beg ,_end) . ,_))
     (pcase (get-text-property beg 'racket-check-syntax-use)
       (`(,beg ,end) (racket--highlight beg end t)))
     (dolist (use uses)
       (pcase use (`(,beg ,end) (racket--highlight beg end nil))))))
  (pcase (get-text-property new 'racket-check-syntax-use)
    (`(,beg ,end)
     (racket--highlight beg end t)
     (dolist (use (get-text-property beg 'racket-check-syntax-def))
       (pcase use (`(,beg ,end) (racket--highlight beg end nil)))))))

(defun racket--point-left (_old _new)
  (racket--unhighlight-all))

(defun racket-check-syntax-mode-quit ()
  (interactive)
  (racket-check-syntax-mode -1))

(defun racket-check-syntax-mode-goto-def ()
  "When point is on a use, go to its definition."
  (interactive)
  (pcase (get-text-property (point) 'racket-check-syntax-use)
    (`(,beg ,_end) (goto-char beg))))

(defun racket-check-syntax-mode-forward-use (amt)
  "When point is on a use, go AMT uses forward. AMT may be negative.

Moving before/after the first/last use wraps around.

If point is instead on a definition, then go to its first use."
  (pcase (get-text-property (point) 'racket-check-syntax-use)
    (`(,beg ,_end)
     (pcase (get-text-property beg 'racket-check-syntax-def)
       (uses (let* ((pt (point))
                    (ix-this (cl-loop for ix from 0 to (1- (length uses))
                                      for use = (nth ix uses)
                                      when (and (<= (car use) pt) (< pt (cadr use)))
                                      return ix))
                    (ix-next (+ ix-this amt))
                    (ix-next (if (> amt 0)
                                 (if (>= ix-next (length uses)) 0 ix-next)
                               (if (< ix-next 0) (1- (length uses)) ix-next)))
                    (next (nth ix-next uses)))
               (goto-char (car next))))))
    (_ (pcase (get-text-property (point) 'racket-check-syntax-def)
         (`((,beg ,_end) . ,_) (goto-char beg))))))

(defun racket-check-syntax-mode-goto-next-use ()
  "When point is on a use, go to the next (sibling) use."
  (interactive)
  (racket-check-syntax-mode-forward-use 1))

(defun racket-check-syntax-mode-goto-prev-use ()
  "When point is on a use, go to the previous (sibling) use."
  (interactive)
  (racket-check-syntax-mode-forward-use -1))

(defun racket-check-syntax-mode-help ()
  (interactive)
  (describe-function #'racket-check-syntax-mode))

(defun racket-check-syntax-mode-rename ()
  (interactive)
  ;; If we're on a def, get its uses. If we're on a use, get its def.
  (let* ((pt (point))
         (uses (get-text-property pt 'racket-check-syntax-def))
         (def  (get-text-property pt 'racket-check-syntax-use)))
    ;; If we got one, get the other.
    (when (or uses def)
      (let* ((uses (or uses (get-text-property (car def)   'racket-check-syntax-def)))
             (def  (or def  (get-text-property (caar uses) 'racket-check-syntax-use)))
             (locs (cons def uses))
             (strs (mapcar (lambda (loc)
                             (apply #'buffer-substring-no-properties loc))
                           locs)))
        ;; Proceed only if all the strings are the same. (They won't
        ;; be for e.g. import bindings.)
        (when (cl-every (lambda (s) (equal (car strs) s))
                        (cdr strs))
          (let ((new (read-from-minibuffer (format "Rename %s to: " (car strs))))
                (marker-pairs
                 (mapcar (lambda (loc)
                           (let ((beg (make-marker))
                                 (end (make-marker)))
                             (set-marker beg (nth 0 loc) (current-buffer))
                             (set-marker end (nth 1 loc) (current-buffer))
                             (list beg end)))
                         locs))
                (point-marker (let ((m (make-marker)))
                                (set-marker m (point) (current-buffer)))))
            (racket-check-syntax-mode -1)
            (dolist (marker-pair marker-pairs)
              (let ((beg (marker-position (nth 0 marker-pair)))
                    (end (marker-position (nth 1 marker-pair))))
                (delete-region beg end)
                (goto-char beg)
                (insert new)))
            (goto-char (marker-position point-marker))
            (racket-check-syntax-mode 1)))))))

(defun racket-check-syntax-mode-goto-next-def ()
  (interactive)
  (let ((pos (next-single-property-change (point) 'racket-check-syntax-def)))
    (when pos
      (unless (get-text-property pos 'racket-check-syntax-def)
        (setq pos (next-single-property-change pos 'racket-check-syntax-def)))
      (and pos (goto-char pos)))))

(defun racket-check-syntax-mode-goto-prev-def ()
  (interactive)
  (let ((pos (previous-single-property-change (point) 'racket-check-syntax-def)))
    (when pos
      (unless (get-text-property pos 'racket-check-syntax-def)
        (setq pos (previous-single-property-change pos 'racket-check-syntax-def)))
      (and pos (goto-char pos)))))

(define-minor-mode racket-check-syntax-mode
  "Analyze the buffer and annotate with information.

The buffer becomes read-only until you exit this minor mode.
However you may navigate the usual ways. When point is on a
definition or use, related items are highlighted and
information is displayed in the echo area. You may also use
special commands to navigate among the definition and its uses.

\\{racket-check-syntax-mode-map}
"
  :lighter " CheckSyntax"
  :keymap (racket--easy-keymap-define
           '(("q"               racket-check-syntax-mode-quit)
             ("h"               racket-check-syntax-mode-help)
             (("j" "TAB")       racket-check-syntax-mode-goto-next-def)
             (("k" "<backtab>") racket-check-syntax-mode-goto-prev-def)
             ("."               racket-check-syntax-mode-goto-def)
             ("n"               racket-check-syntax-mode-goto-next-use)
             ("p"               racket-check-syntax-mode-goto-prev-use)
             ("r"               racket-check-syntax-mode-rename)))
  (unless (eq major-mode 'racket-mode)
    (setq racket-check-syntax-mode nil)
    (user-error "racket-check-syntax-mode only works with Racket Mode buffers"))
  (racket--check-syntax-stop)
  (when racket-check-syntax-mode
    (racket--check-syntax-start)))

(defun racket--check-syntax-start ()
  (let ((buf (current-buffer)))
    (racket--save-if-changed)
    (message "Running check-syntax analysis...")
    (racket--cmd/async-raw
     `(check-syntax ,(racket--buffer-file-name))
     (lambda (response)
       (with-current-buffer buf
        (pcase response
          (`(error ,m)
           (racket-check-syntax-mode -1)
           (error m))
          (`(ok ())
           (racket-check-syntax-mode -1)
           (user-error "No bindings found"))
          (`(ok ,xs)
           (message "Marking up buffer...")
           (racket--check-syntax-insert xs)
           (message ""))))))))

(defun racket--check-syntax-insert (xs)
  (with-silent-modifications
    (dolist (x xs)
      (pcase x
        (`(,`info ,beg ,end ,str)
         (put-text-property beg end 'help-echo str))
        (`(,`def/uses ,def-beg ,def-end ,uses)
         (add-text-properties def-beg
                              def-end
                              (list 'racket-check-syntax-def uses
                                    'point-entered #'racket--point-entered
                                    'point-left    #'racket--point-left))
         (dolist (use uses)
           (pcase-let* ((`(,use-beg ,use-end) use))
             (add-text-properties use-beg
                                  use-end
                                  (list 'racket-check-syntax-use (list def-beg
                                                                       def-end)
                                        'point-entered #'racket--point-entered
                                        'point-left    #'racket--point-left)))))))
    (setq buffer-read-only t)
    (setq header-line-format
          "Check Syntax. Buffer is read-only. Press h for help, q to quit.")
    ;; Make 'point-entered and 'point-left work in Emacs 25+. Note
    ;; that this is somewhat of a hack -- I spent a lot of time trying
    ;; to Do the Right Thing using the new cursor-sensor-mode, but
    ;; could not get it to work satisfactorily. See:
    ;; http://emacs.stackexchange.com/questions/29813/point-motion-strategy-for-emacs-25-and-older
    (setq-local inhibit-point-motion-hooks nil)
    ;; Go to next definition, as an affordance/hint what this does:
    (racket-check-syntax-mode-goto-next-def)))

(defun racket--check-syntax-stop ()
  (setq header-line-format nil)
  (with-silent-modifications
    (remove-text-properties (point-min)
                            (point-max)
                            '(help-echo nil
                              racket-check-syntax-def nil
                              racket-check-syntax-use nil
                              point-entered
                              point-left))
    (racket--unhighlight-all)
    (setq buffer-read-only nil)))

;;; align

(defun racket-align ()
  "Align values in the same column.

Useful for binding forms like \"let\" and \"parameterize\",
conditionals like \"cond\" and \"match\", association lists, and
any series of couples like the arguments to \"hash\".

Before choosing this command, put point on the first of a series
of \"couples\". A couple is:

- A list of two or more sexprs: \"[sexpr val sexpr ...]\".
- Two sexprs: \"sexpr val\".

Each \"val\" moves to the same column and is
`prog-indent-sexp'-ed (in case it is a multi-line form).

For example with point on the \"[\" before \"a\":

#+BEGIN_SRC racket
    Before             After

    (let ([a 12]       (let ([a   12]
          [bar 23])          [bar 23])
      ....)              ....)

    '([a . 12]         '([a   . 12]
      [bar . 23])        [bar . 23])

    (cond [a? #t]      (cond [a?   #t]
          [b? (f x           [b?   (f x
                 y)]                  y)]
          [else #f])         [else #f])
#+END_SRC

Or with point on the quote before \"a\":

#+BEGIN_SRC racket
    (list 'a 12        (list 'a   12
          'bar 23)           'bar 23)
#+END_SRC

If more than one couple is on the same line, none are aligned,
because it is unclear where the value column should be. For
example the following form will not change; `racket-align' will
display an error message:

#+BEGIN_SRC racket
    (let ([a 0][b 1]
          [c 2])       error; unchanged
      ....)
#+END_SRC

When a couple's sexprs start on different lines, that couple is
ignored. Other, single-line couples in the series are aligned as
usual. For example:

#+BEGIN_SRC racket
    (let ([foo         (let ([foo
           0]                 0]
          [bar 1]            [bar 1]
          [x 2])             [x   2])
      ....)              ....)
#+END_SRC

See also: `racket-unalign'."
  (interactive)
  (save-excursion
    (let ((listp (eq ?\( (char-syntax (char-after))))
          (prev-line 0)
          (max-col 0))
      (racket--for-each-couple listp
                               (lambda ()
                                 (setq max-col (max max-col (current-column)))
                                 (let ((this-line (line-number-at-pos)))
                                   (when (= prev-line this-line)
                                     (user-error
                                      "Can't align if any couples are on same line"))
                                   (setq prev-line this-line))))
      (racket--for-each-couple listp
                               (lambda ()
                                 (indent-to max-col)
                                 (prog-indent-sexp))))))

(defun racket-unalign ()
  "The opposite of `racket-align'.

Effectively does M-x `just-one-space' and `prog-indent-sexp' for
each couple's value."
  (interactive)
  (save-excursion
    (let ((listp (eq ?\( (char-syntax (char-after)))))
      (racket--for-each-couple listp
                               (lambda ()
                                 (just-one-space)
                                 (prog-indent-sexp))))))

(defun racket--for-each-couple (listp f)
  "Move point to each value sexp of a couple, and `funcall' F.

Only call F when the couple's sexprs are on the same line.

When LISTP is true, expects couples to be `[id val]`, else `id val`."
  (save-excursion
    (condition-case ()
        (while t
          (when listp
            (down-list))
          (forward-sexp)
          (let ((line (line-number-at-pos)))
            (forward-sexp)
            (backward-sexp)
            (when (= line (line-number-at-pos))
              ;; Defensive: Backup over any prefix or punctuation
              ;; chars just in case backward-sexp didn't (although it
              ;; should have if our syntax table is correct).
              (while (memq (char-syntax (char-before)) '(?\' ?\.))
                (goto-char (1- (point))))
              (funcall f)))
          ;; On to the next couple...
          (if listp
              (up-list)
            (forward-sexp)))
      (scan-error nil))))

(provide 'racket-edit)

;; racket-edit.el ends here
