Support internal prompts

Some people do fancy stuff with the prompt (e.g. multiline, colouring).
This offers some support for it.

The haskell-interactive-mode-prompt-previous/next used the prompt regex
to search for the prompt, but this doesn't work with variable
prompts (i.e. containing module names). Now they use text property
search.

Author: fice-t

haskell-commands.el

@@ -104,9 +104,9 @@ You can create new session using function `haskell-session-make'."
                                                     ":set -v1"
                                                     ":set +c") ; :type-at in GHC 8+
                                                   "\n"))
-          (haskell-process-send-string process ":set prompt \"\\4\"")
           (haskell-process-send-string process (format ":set prompt2 \"%s\""
-                                                       haskell-interactive-prompt2)))
+                                                       haskell-interactive-prompt2))
+          (haskell-process-send-string process ":set prompt \"\\4\""))
 
     :live (lambda (process buffer)
             (when (haskell-process-consume
@@ -134,8 +134,20 @@ If I break, you can:
   1. Restart:           M-x haskell-process-restart
   2. Configure logging: C-h v haskell-process-log (useful for debugging)
   3. General config:    M-x customize-mode
-  4. Hide these tips:   C-h v haskell-process-show-debug-tips")))))))
-
+  4. Hide these tips:   C-h v haskell-process-show-debug-tips")))
+                (unless haskell-interactive-use-interactive-prompt
+                  (with-current-buffer (haskell-session-interactive-buffer
+                                        (haskell-process-session process))
+                    (setq-local haskell-interactive-mode-prompt-start (point-max-marker)))
+                  ;; Now it's safe to set the prompt
+                  ;; Make sure to double escape any newlines
+                  (haskell-interactive-mode-run-expr
+                   (format ":set prompt \"%s\\4\""
+                           (replace-regexp-in-string "\n"
+                                                     "\\n"
+                                                     haskell-interactive-prompt
+                                                     nil
+                                                     t))))))))
 (defun haskell-commands-process ()
   "Get the Haskell session, throws an error if not available."
   (or (haskell-session-process (haskell-session-maybe))

haskell-customize.el

@@ -324,6 +324,17 @@ The default is `haskell-interactive-prompt' with the last > replaced with |."
   :type 'string
   :group 'haskell-interactive)
 
+(defcustom haskell-interactive-use-interactive-prompt t
+  "Non-nil means that haskell-interactive uses its prompt at the
+Emacs side rather than setting it in GHCi directly.
+
+This is only useful to disable when you want a prompt containing
+your modules (as GHCi does by default), or if you apply extra
+properties (colours, etc.) to your prompt through GHCi."
+  :type 'boolean
+  :group 'haskell-interactive)
+
+
 (defcustom haskell-interactive-mode-eval-mode
   nil
   "Use the given mode's font-locking to render some text."

haskell-doc.el

@@ -1517,6 +1517,12 @@ If SYNC is non-nil, make the call synchronously instead."
                (setq response nil)
              ;; Remove a newline at the end
              (setq response (replace-regexp-in-string "\n\\'" "" response))
+             (unless haskell-interactive-use-interactive-prompt
+               ;; Remove the extra prompt (may span multiple lines)
+               (setq response (mapconcat #'identity
+                                         (nbutlast (split-string response "\n")
+                                                   (1+ (cl-count ?\n haskell-interactive-prompt)))
+                                         "\n")))
              ;; Propertize for eldoc
              (save-match-data
                (when (string-match " :: " response)

haskell-interactive-mode.el

@@ -247,7 +247,9 @@ do the
 :}"
   (if (not (string-match-p "\n" expr))
       expr
-    (let ((len (length haskell-interactive-prompt))
+    (let ((len (if haskell-interactive-use-interactive-prompt
+                   (length haskell-interactive-prompt)
+                 (length (last (split-string haskell-interactive-prompt "\n")))))
           (lines (split-string expr "\n")))
       (cl-loop for elt on (cdr lines) do
                (setcar elt (substring (car elt) len)))
@@ -295,21 +297,30 @@ do the
 (defun haskell-interactive-mode-prompt (&optional session)
   "Show a prompt at the end of the REPL buffer.
 If SESSION is non-nil, use the REPL buffer associated with
-SESSION, otherwise operate on the current buffer."
+SESSION, otherwise operate on the current buffer. The prompt
+inserted is specified by `haskell-interactive-prompt'.
+When `haskell-interactive-use-interactive-prompt' is non-nil,
+the prompt is inserted in this function. Otherwise it was already
+set in the `haskell-process-send-startup' and has already been
+inserted in the buffer by the process."
   (with-current-buffer (if session
                            (haskell-session-interactive-buffer session)
                          (current-buffer))
     (goto-char (point-max))
-    (let ((prompt (propertize haskell-interactive-prompt
-                              'font-lock-face 'haskell-interactive-face-prompt
-                              'prompt t
-                              'read-only t
-                              'rear-nonsticky t)))
-      ;; At the time of writing, front-stickying the first char gives an error
-      ;; Has unfortunate side-effect of being able to insert before the prompt
-      (insert (substring prompt 0 1)
-              (propertize (substring prompt 1)
-                          'front-sticky t)))
+    (if haskell-interactive-use-interactive-prompt
+        (let ((prompt (propertize haskell-interactive-prompt
+                                  'font-lock-face 'haskell-interactive-face-prompt
+                                  'prompt t
+                                  'read-only t
+                                  'rear-nonsticky t)))
+          ;; At the time of writing, front-stickying the first char gives an error
+          ;; Has unfortunate side-effect of being able to insert before the prompt
+          (insert (substring prompt 0 1)
+                  (propertize (substring prompt 1)
+                              'front-sticky t)))
+      (let ((inhibit-read-only t))
+        (unless (= (point) (point-min))
+          (put-text-property (1- (point)) (point) 'prompt t))))
     (let ((marker (setq-local haskell-interactive-mode-prompt-start (make-marker))))
       (set-marker marker (point)))
     (when haskell-interactive-mode-scroll-to-bottom
@@ -322,16 +333,13 @@ SESSION, otherwise operate on the current buffer."
     (let ((prop-text (propertize text
                                  'font-lock-face 'haskell-interactive-face-result
                                  'front-sticky t
-                                 'prompt t
                                  'read-only t
                                  'rear-nonsticky t
                                  'result t)))
       (when (string= text haskell-interactive-prompt2)
-        (put-text-property 0
-                           (length haskell-interactive-prompt2)
-                           'font-lock-face
-                           'haskell-interactive-face-prompt2
-                           prop-text))
+        (setq prop-text (propertize prop-text
+                                    'font-lock-face 'haskell-interactive-face-prompt2
+                                    'prompt2 t)))
       (insert (ansi-color-apply prop-text))
       (haskell-interactive-mode-handle-h)
       (let ((marker (setq-local haskell-interactive-mode-result-end (make-marker))))
@@ -973,20 +981,34 @@ don't care when the thing completes as long as it's soonish."
       (setq haskell-interactive-mode-history-index 0)
       (haskell-interactive-mode-history-toggle -1))))
 
-(defun haskell-interactive-mode-prompt-previous ()
-  "Jump to the previous prompt."
-  (interactive)
-  (let ((prev-prompt-pos
-         (save-excursion
-           (beginning-of-line) ;; otherwise prompt at current line matches
-           (and (search-backward-regexp (haskell-interactive-prompt-regex) nil t)
-                (match-end 0)))))
-    (when prev-prompt-pos (goto-char prev-prompt-pos))))
-
-(defun haskell-interactive-mode-prompt-next ()
-  "Jump to the next prompt."
-  (interactive)
-  (search-forward-regexp (haskell-interactive-prompt-regex) nil t))
+(defun haskell-interactive-mode-prompt-previous (&optional arg)
+  "Jump to the ARGth previous prompt."
+  (interactive "p")
+  (if (< arg 0)
+      (haskell-interactive-mode-prompt-next (- arg))
+    (end-of-line 1)
+    (unless (or (get-text-property (1- (point)) 'prompt)
+                (zerop arg))
+      (cl-incf arg 0.5)) ; do it an extra time if not at a prompt
+    (dotimes (_ (* 2 arg))
+      (goto-char (or (previous-single-property-change (point) 'prompt)
+                     (point))))
+    (when (get-text-property (point) 'prompt)
+      ;; went too far (at first prompt)
+      (goto-char (next-single-property-change (point) 'prompt)))))
+
+(defun haskell-interactive-mode-prompt-next (&optional arg)
+  "Jump to the ARGth next prompt."
+  (interactive "p")
+  (if (< arg 0)
+      (haskell-interactive-mode-prompt-previous (- arg))
+    (when (and (get-text-property (point) 'prompt)
+               (not (zerop arg)))
+      ;; don't start on a prompt
+      (haskell-interactive-mode-prompt-previous 1))
+    (dotimes (_ (* 2 arg))
+      (goto-char (or (next-single-property-change (point) 'prompt)
+                     (point-max))))))
 
 (defun haskell-interactive-mode-clear ()
   "Clear the screen and put any current input into the history."
@@ -1054,14 +1076,15 @@ If there is one, pop that up in a buffer, similar to `debug-on-error'."
   (with-current-buffer (haskell-session-interactive-buffer session)
     (save-excursion
       (haskell-interactive-mode-goto-end-point)
-      (insert (if mode
-                  (haskell-fontify-as-mode
-                   (concat message "\n")
-                   mode)
-                (propertize (concat message "\n")
-                            'front-sticky t
-                            'read-only t
-                            'rear-nonsticky t))))))
+      (let ((inhibit-read-only t))
+        (insert (if mode
+                    (haskell-fontify-as-mode
+                     (concat message "\n")
+                     mode)
+                  (propertize (concat message "\n")
+                              'front-sticky t
+                              'read-only t
+                              'rear-nonsticky t)))))))
 
 (defun haskell-interactive-mode-splices-buffer (session)
   "Get the splices buffer for the current SESSION."

haskell-repl.el

@@ -23,7 +23,8 @@
 (defun haskell-interactive-handle-expr ()
   "Handle an inputted expression at the REPL."
   (let ((expr (haskell-interactive-mode-input)))
-    (if (string= "" (replace-regexp-in-string " " "" expr))
+    (if (and (string= "" (replace-regexp-in-string " " "" expr))
+             haskell-interactive-use-interactive-prompt)
         ;; Just make a new prompt on space-only input
         (progn
           (goto-char (point-max))
@@ -116,8 +117,9 @@
       (delete-region (1+ haskell-interactive-mode-prompt-start) (point))
       (goto-char (point-max))
       (let ((start (point)))
-        (insert (haskell-fontify-as-mode text
-                                         haskell-interactive-mode-eval-mode))
+        (insert (ansi-color-apply (haskell-fontify-as-mode
+                                   text
+                                   haskell-interactive-mode-eval-mode)))
         (when haskell-interactive-mode-collapse
           (haskell-collapse start (point)))))))