forked from clojure-emacs/cider
-
Notifications
You must be signed in to change notification settings - Fork 0
/
cider-repl.el
1852 lines (1646 loc) · 77.7 KB
/
cider-repl.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; cider-repl.el --- CIDER REPL mode interactions -*- lexical-binding: t -*-
;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
;; Copyright © 2013-2022 Bozhidar Batsov, Artur Malabarba and CIDER contributors
;;
;; Author: Tim King <[email protected]>
;; Phil Hagelberg <[email protected]>
;; Bozhidar Batsov <[email protected]>
;; Artur Malabarba <[email protected]>
;; Hugo Duncan <[email protected]>
;; Steve Purcell <[email protected]>
;; Reid McKenzie <[email protected]>
;; 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 3 of the License, 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.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;; This file is not part of GNU Emacs.
;;; Commentary:
;; This functionality concerns `cider-repl-mode' and REPL interaction. For
;; REPL/connection life-cycle management see cider-connection.el.
;;; Code:
(require 'cl-lib)
(require 'easymenu)
(require 'image)
(require 'map)
(require 'seq)
(require 'subr-x)
(require 'clojure-mode)
(require 'sesman)
(require 'cider-client)
(require 'cider-doc)
(require 'cider-test)
(require 'cider-eldoc) ; for cider-eldoc-setup
(require 'cider-common)
(require 'cider-util)
(require 'cider-resolve)
(declare-function cider-inspect "cider-inspector")
(defgroup cider-repl nil
"Interaction with the REPL."
:prefix "cider-repl-"
:group 'cider)
(defface cider-repl-prompt-face
'((t (:inherit font-lock-keyword-face)))
"Face for the prompt in the REPL buffer.")
(defface cider-repl-stdout-face
'((t (:inherit font-lock-string-face)))
"Face for STDOUT output in the REPL buffer.")
(defface cider-repl-stderr-face
'((t (:inherit font-lock-warning-face)))
"Face for STDERR output in the REPL buffer."
:package-version '(cider . "0.6.0"))
(defface cider-repl-input-face
'((t (:bold t)))
"Face for previous input in the REPL buffer.")
(defface cider-repl-result-face
'((t ()))
"Face for the result of an evaluation in the REPL buffer.")
(defcustom cider-repl-pop-to-buffer-on-connect t
"Controls whether to pop to the REPL buffer on connect.
When set to nil the buffer will only be created, and not displayed. When
set to `display-only' the buffer will be displayed, but it will not become
focused. Otherwise the buffer is displayed and focused."
:type '(choice (const :tag "Create the buffer, but don't display it" nil)
(const :tag "Create and display the buffer, but don't focus it"
display-only)
(const :tag "Create, display, and focus the buffer" t)))
(defcustom cider-repl-display-in-current-window nil
"Controls whether the REPL buffer is displayed in the current window."
:type 'boolean)
(make-obsolete-variable 'cider-repl-scroll-on-output 'scroll-conservatively "0.21")
(defcustom cider-repl-use-pretty-printing t
"Control whether results in the REPL are pretty-printed or not.
The REPL will use the printer specified in `cider-print-fn'.
The `cider-toggle-pretty-printing' command can be used to interactively
change the setting's value."
:type 'boolean)
(make-obsolete-variable 'cider-repl-pretty-print-width 'cider-print-options "0.21")
(defcustom cider-repl-use-content-types nil
"Control whether REPL results are presented using content-type information.
The `cider-repl-toggle-content-types' command can be used to interactively
change the setting's value."
:type 'boolean
:package-version '(cider . "0.17.0"))
(defcustom cider-repl-auto-detect-type t
"Control whether to auto-detect the REPL type using track-state information.
If you disable this you'll have to manually change the REPL type between
Clojure and ClojureScript when invoking REPL type changing forms.
Use `cider-set-repl-type' to manually change the REPL type."
:type 'boolean
:safe #'booleanp
:package-version '(cider . "0.18.0"))
(defcustom cider-repl-use-clojure-font-lock t
"Non-nil means to use Clojure mode font-locking for input and result.
Nil means that `cider-repl-input-face' and `cider-repl-result-face'
will be used."
:type 'boolean
:package-version '(cider . "0.10.0"))
(defcustom cider-repl-require-ns-on-set nil
"Controls whether to require the ns before setting it in the REPL."
:type 'boolean
:package-version '(cider . "0.22.0"))
(defcustom cider-repl-result-prefix ""
"The prefix displayed in the REPL before a result value.
By default there's no prefix, but you can specify something
like \"=>\" if want results to stand out more."
:type 'string
:group 'cider
:package-version '(cider . "0.5.0"))
(defcustom cider-repl-tab-command 'cider-repl-indent-and-complete-symbol
"Select the command to be invoked by the TAB key.
The default option is `cider-repl-indent-and-complete-symbol'. If
you'd like to use the default Emacs behavior use
`indent-for-tab-command'."
:type 'symbol)
(make-obsolete-variable 'cider-repl-print-length 'cider-print-options "0.21")
(make-obsolete-variable 'cider-repl-print-level 'cider-print-options "0.21")
(defvar cider-repl-require-repl-utils-code
'((clj . "(clojure.core/apply clojure.core/require clojure.main/repl-requires)")
(cljs . "(require '[cljs.repl :refer [apropos dir doc find-doc print-doc pst source]])")))
(defcustom cider-repl-init-code (list (cdr (assoc 'clj cider-repl-require-repl-utils-code)))
"Clojure code to evaluate when starting a REPL.
Will be evaluated with bindings for set!-able vars in place."
:type '(list string)
:package-version '(cider . "0.21.0"))
(defcustom cider-repl-display-help-banner t
"When non-nil a bit of help text will be displayed on REPL start."
:type 'boolean
:package-version '(cider . "0.11.0"))
;;;; REPL buffer local variables
(defvar-local cider-repl-input-start-mark nil)
(defvar-local cider-repl-prompt-start-mark nil)
(defvar-local cider-repl-old-input-counter 0
"Counter used to generate unique `cider-old-input' properties.
This property value must be unique to avoid having adjacent inputs be
joined together.")
(defvar-local cider-repl-input-history '()
"History list of strings read from the REPL buffer.")
(defvar-local cider-repl-input-history-items-added 0
"Variable counting the items added in the current session.")
(defvar-local cider-repl-output-start nil
"Marker for the start of output.
Currently its only purpose is to facilitate `cider-repl-clear-buffer'.")
(defvar-local cider-repl-output-end nil
"Marker for the end of output.
Currently its only purpose is to facilitate `cider-repl-clear-buffer'.")
(defun cider-repl-tab ()
"Invoked on TAB keystrokes in `cider-repl-mode' buffers."
(interactive)
(funcall cider-repl-tab-command))
(defun cider-repl-reset-markers ()
"Reset all REPL markers."
(dolist (markname '(cider-repl-output-start
cider-repl-output-end
cider-repl-prompt-start-mark
cider-repl-input-start-mark))
(set markname (make-marker))
(set-marker (symbol-value markname) (point))))
;;; REPL init
(defvar-local cider-repl-ns-cache nil
"A dict holding information about all currently loaded namespaces.
This cache is stored in the connection buffer.")
(defvar cider-mode)
(declare-function cider-refresh-dynamic-font-lock "cider-mode")
(defun cider-repl--state-handler (response)
"Handle server state contained in RESPONSE."
(with-demoted-errors "Error in `cider-repl--state-handler': %s"
(when (member "state" (nrepl-dict-get response "status"))
(nrepl-dbind-response response (repl-type changed-namespaces)
(when (and repl-type cider-repl-auto-detect-type)
(cider-set-repl-type repl-type))
(unless (nrepl-dict-empty-p changed-namespaces)
(setq cider-repl-ns-cache (nrepl-dict-merge cider-repl-ns-cache changed-namespaces))
(dolist (b (buffer-list))
(with-current-buffer b
;; Metadata changed, so signatures may have changed too.
(setq cider-eldoc-last-symbol nil)
(when (or cider-mode (derived-mode-p 'cider-repl-mode))
(when-let* ((ns-dict (or (nrepl-dict-get changed-namespaces (cider-current-ns))
(let ((ns-dict (cider-resolve--get-in (cider-current-ns))))
(when (seq-find (lambda (ns) (nrepl-dict-get changed-namespaces ns))
(nrepl-dict-get ns-dict "aliases"))
ns-dict)))))
(cider-refresh-dynamic-font-lock ns-dict))))))))))
(defun cider-repl-require-repl-utils ()
"Require standard REPL util functions into the current REPL."
(interactive)
(let* ((current-repl (cider-current-repl nil 'ensure))
(require-code (cdr (assoc (cider-repl-type current-repl) cider-repl-require-repl-utils-code))))
(nrepl-send-sync-request
(lax-plist-put
(nrepl--eval-request require-code (cider-current-ns))
"inhibit-cider-middleware" "true")
current-repl)))
(defun cider-repl-init-eval-handler (&optional callback)
"Make an nREPL evaluation handler for use during REPL init.
Run CALLBACK once the evaluation is complete."
(nrepl-make-response-handler (current-buffer)
(lambda (_buffer _value))
(lambda (buffer out)
(cider-repl-emit-stdout buffer out))
(lambda (buffer err)
(cider-repl-emit-stderr buffer err))
(lambda (buffer)
(cider-repl-emit-prompt buffer)
(when callback
(funcall callback)))))
(defun cider-repl-eval-init-code (&optional callback)
"Evaluate `cider-repl-init-code' in the current REPL.
Run CALLBACK once the evaluation is complete."
(interactive)
(let* ((request (map-merge 'hash-table
(cider--repl-request-map fill-column)
'(("inhibit-cider-middleware" "true")))))
(cider-nrepl-request:eval
;; Ensure we evaluate _something_ so the initial namespace is correctly set
(thread-first (or cider-repl-init-code '("nil"))
(string-join "\n"))
(cider-repl-init-eval-handler callback)
nil
(line-number-at-pos (point))
(cider-column-number-at-pos (point))
(thread-last request
(map-pairs)
(seq-mapcat #'identity)))))
(defun cider-repl-init (buffer &optional callback)
"Initialize the REPL in BUFFER.
BUFFER must be a REPL buffer with `cider-repl-mode' and a running
client process connection. CALLBACK will be run once the REPL is
fully initialized."
(when cider-repl-display-in-current-window
(add-to-list 'same-window-buffer-names (buffer-name buffer)))
(pcase cider-repl-pop-to-buffer-on-connect
(`display-only
(let ((orig-buffer (current-buffer)))
(display-buffer buffer)
;; User popup-rules (specifically `:select nil') can cause the call to
;; `display-buffer' to reset the current Emacs buffer to the clj/cljs
;; buffer that the user ran `jack-in' from - we need the current-buffer
;; to be the repl to initialize, so reset it back here to be resilient
;; against user config
(set-buffer orig-buffer)))
((pred identity) (pop-to-buffer buffer)))
(with-current-buffer buffer
(cider-repl--insert-banner)
(cider-repl--insert-startup-commands)
(when-let* ((window (get-buffer-window buffer t)))
(with-selected-window window
(recenter (- -1 scroll-margin))))
(cider-repl-eval-init-code callback))
buffer)
(defun cider-repl--insert-banner ()
"Insert the banner in the current REPL buffer."
(insert-before-markers
(propertize (cider-repl--banner) 'font-lock-face 'font-lock-comment-face))
(when cider-repl-display-help-banner
(insert-before-markers
(propertize (cider-repl--help-banner) 'font-lock-face 'font-lock-comment-face))))
(defun cider-repl--insert-startup-commands ()
"Insert the values from params specified in PARAM-TUPLES.
PARAM-TUPLES are tuples of (param-key description) or (param-key
description transform) where transform is called with the param-value if
present."
(cl-labels
((emit-comment
(contents)
(insert-before-markers
(propertize
(if (string-blank-p contents) ";;\n" (concat ";; " contents "\n"))
'font-lock-face 'font-lock-comment-face))))
(let ((jack-in-command (plist-get cider-launch-params :jack-in-cmd))
(cljs-repl-type (plist-get cider-launch-params :cljs-repl-type))
(cljs-init-form (plist-get cider-launch-params :repl-init-form)))
(when jack-in-command
;; spaces to align with the banner
(emit-comment (concat " Startup: " jack-in-command)))
(when (or cljs-repl-type cljs-init-form)
(emit-comment "")
(when cljs-repl-type
(emit-comment (concat "ClojureScript REPL type: " (symbol-name cljs-repl-type))))
(when cljs-init-form
(emit-comment (concat "ClojureScript REPL init form: " cljs-init-form)))
(emit-comment "")))))
(defun cider-repl--banner ()
"Generate the welcome REPL buffer banner."
(cond
((cider--clojure-version) (cider-repl--clojure-banner))
((cider--babashka-version) (cider-repl--babashka-banner))
(t (cider-repl--basic-banner))))
(defun cider-repl--clojure-banner ()
"Generate the welcome REPL buffer banner for Clojure(Script)."
(format ";; Connected to nREPL server - nrepl://%s:%s
;; CIDER %s, nREPL %s
;; Clojure %s, Java %s
;; Docs: (doc function-name)
;; (find-doc part-of-name)
;; Source: (source function-name)
;; Javadoc: (javadoc java-object-or-class)
;; Exit: <C-c C-q>
;; Results: Stored in vars *1, *2, *3, an exception in *e;
"
(plist-get nrepl-endpoint :host)
(plist-get nrepl-endpoint :port)
(cider--version)
(cider--nrepl-version)
(cider--clojure-version)
(cider--java-version)))
(defun cider-repl--babashka-banner ()
"Generate the welcome REPL buffer banner for Babashka."
(format ";; Connected to nREPL server - nrepl://%s:%s
;; CIDER %s, babashka.nrepl %s
;; Babashka %s
;; Docs: (doc function-name)
;; (find-doc part-of-name)
;; Source: (source function-name)
;; Javadoc: (javadoc java-object-or-class)
;; Exit: <C-c C-q>
;; Results: Stored in vars *1, *2, *3, an exception in *e;
"
(plist-get nrepl-endpoint :host)
(plist-get nrepl-endpoint :port)
(cider--version)
(cider--babashka-nrepl-version)
(cider--babashka-version)))
(defun cider-repl--basic-banner ()
"Generate a basic banner with minimal info."
(format ";; Connected to nREPL server - nrepl://%s:%s
;; CIDER %s
"
(plist-get nrepl-endpoint :host)
(plist-get nrepl-endpoint :port)
(cider--version)))
(defun cider-repl--help-banner ()
"Generate the help banner."
(substitute-command-keys
";; ======================================================================
;; If you're new to CIDER it is highly recommended to go through its
;; user manual first. Type <M-x cider-view-manual> to view it.
;; In case you're seeing any warnings you should consult the manual's
;; \"Troubleshooting\" section.
;;
;; Here are a few tips to get you started:
;;
;; * Press <\\[describe-mode]> to see a list of the keybindings available (this
;; will work in every Emacs buffer)
;; * Press <\\[cider-repl-handle-shortcut]> to quickly invoke some REPL command
;; * Press <\\[cider-switch-to-last-clojure-buffer]> to switch between the REPL and a Clojure file
;; * Press <\\[cider-find-var]> to jump to the source of something (e.g. a var, a
;; Java method)
;; * Press <\\[cider-doc]> to view the documentation for something (e.g.
;; a var, a Java method)
;; * Print CIDER's refcard and keep it close to your keyboard.
;;
;; CIDER is super customizable - try <M-x customize-group cider> to
;; get a feel for this. If you're thirsty for knowledge you should try
;; <M-x cider-drink-a-sip>.
;;
;; If you think you've encountered a bug (or have some suggestions for
;; improvements) use <M-x cider-report-bug> to report it.
;;
;; Above all else - don't panic! In case of an emergency - procure
;; some (hard) cider and enjoy it responsibly!
;;
;; You can remove this message with the <M-x cider-repl-clear-help-banner> command.
;; You can disable it from appearing on start by setting
;; `cider-repl-display-help-banner' to nil.
;; ======================================================================
"))
;;; REPL interaction
(defun cider-repl--in-input-area-p ()
"Return t if in input area."
(<= cider-repl-input-start-mark (point)))
(defun cider-repl--current-input (&optional until-point-p)
"Return the current input as string.
The input is the region from after the last prompt to the end of
buffer. If UNTIL-POINT-P is non-nil, the input is until the current
point."
(buffer-substring-no-properties cider-repl-input-start-mark
(if until-point-p
(point)
(point-max))))
(defun cider-repl-previous-prompt ()
"Move backward to the previous prompt."
(interactive)
(cider-repl--find-prompt t))
(defun cider-repl-next-prompt ()
"Move forward to the next prompt."
(interactive)
(cider-repl--find-prompt))
(defun cider-repl--find-prompt (&optional backward)
"Find the next prompt.
If BACKWARD is non-nil look backward."
(let ((origin (point))
(cider-repl-prompt-property 'field))
(while (progn
(cider-search-property-change cider-repl-prompt-property backward)
(not (or (cider-end-of-proprange-p cider-repl-prompt-property) (bobp) (eobp)))))
(unless (cider-end-of-proprange-p cider-repl-prompt-property)
(goto-char origin))))
(defun cider-search-property-change (prop &optional backward)
"Search forward for a property change to PROP.
If BACKWARD is non-nil search backward."
(cond (backward
(goto-char (previous-single-char-property-change (point) prop)))
(t
(goto-char (next-single-char-property-change (point) prop)))))
(defun cider-end-of-proprange-p (property)
"Return t if at the the end of a property range for PROPERTY."
(and (get-char-property (max (point-min) (1- (point))) property)
(not (get-char-property (point) property))))
(defun cider-repl--mark-input-start ()
"Mark the input start."
(set-marker cider-repl-input-start-mark (point) (current-buffer)))
(defun cider-repl--mark-output-start ()
"Mark the output start."
(set-marker cider-repl-output-start (point))
(set-marker cider-repl-output-end (point)))
(defun cider-repl-mode-beginning-of-defun (&optional arg)
"Move to the beginning of defun.
If given a negative value of ARG, move to the end of defun."
(if (and arg (< arg 0))
(cider-repl-mode-end-of-defun (- arg))
(dotimes (_ (or arg 1))
(cider-repl-previous-prompt))))
(defun cider-repl-mode-end-of-defun (&optional arg)
"Move to the end of defun.
If given a negative value of ARG, move to the beginning of defun."
(if (and arg (< arg 0))
(cider-repl-mode-beginning-of-defun (- arg))
(dotimes (_ (or arg 1))
(cider-repl-next-prompt))))
(defun cider-repl-beginning-of-defun ()
"Move to beginning of defun."
(interactive)
;; We call `beginning-of-defun' if we're at the start of a prompt
;; already, to trigger `cider-repl-mode-beginning-of-defun' by means
;; of the locally bound `beginning-of-defun-function', in order to
;; jump to the start of the previous prompt.
(if (and (not (cider-repl--at-prompt-start-p))
(cider-repl--in-input-area-p))
(goto-char cider-repl-input-start-mark)
(beginning-of-defun)))
(defun cider-repl-end-of-defun ()
"Move to end of defun."
(interactive)
;; C.f. `cider-repl-beginning-of-defun'
(if (and (not (= (point) (point-max)))
(cider-repl--in-input-area-p))
(goto-char (point-max))
(end-of-defun)))
(defun cider-repl-bol-mark ()
"Set the mark and go to the beginning of line or the prompt."
(interactive)
(unless mark-active
(set-mark (point)))
(move-beginning-of-line 1))
(defun cider-repl--at-prompt-start-p ()
"Return t if point is at the start of prompt.
This will not work on non-current prompts."
(= (point) cider-repl-input-start-mark))
(defmacro cider-save-marker (marker &rest body)
"Save MARKER and execute BODY."
(declare (debug t))
(let ((pos (make-symbol "pos")))
`(let ((,pos (marker-position ,marker)))
(prog1 (progn . ,body)
(set-marker ,marker ,pos)))))
(put 'cider-save-marker 'lisp-indent-function 1)
(defun cider-repl-prompt-default (namespace)
"Return a prompt string that mentions NAMESPACE."
(format "%s> " namespace))
(defun cider-repl-prompt-abbreviated (namespace)
"Return a prompt string that abbreviates NAMESPACE."
(format "%s> " (cider-abbreviate-ns namespace)))
(defun cider-repl-prompt-lastname (namespace)
"Return a prompt string with the last name in NAMESPACE."
(format "%s> " (cider-last-ns-segment namespace)))
(defcustom cider-repl-prompt-function #'cider-repl-prompt-default
"A function that returns a prompt string.
Takes one argument, a namespace name.
For convenience, three functions are already provided for this purpose:
`cider-repl-prompt-lastname', `cider-repl-prompt-abbreviated', and
`cider-repl-prompt-default'."
:type '(choice (const :tag "Full namespace" cider-repl-prompt-default)
(const :tag "Abbreviated namespace" cider-repl-prompt-abbreviated)
(const :tag "Last name in namespace" cider-repl-prompt-lastname)
(function :tag "Custom function"))
:package-version '(cider . "0.9.0"))
(defun cider-repl--insert-prompt (namespace)
"Insert the prompt (before markers!), taking into account NAMESPACE.
Set point after the prompt.
Return the position of the prompt beginning."
(goto-char cider-repl-input-start-mark)
(cider-save-marker cider-repl-output-start
(cider-save-marker cider-repl-output-end
(unless (bolp) (insert-before-markers "\n"))
(let ((prompt-start (point))
(prompt (funcall cider-repl-prompt-function namespace)))
(cider-propertize-region
'(font-lock-face cider-repl-prompt-face read-only t intangible t
field cider-repl-prompt
rear-nonsticky (field read-only font-lock-face intangible))
(insert-before-markers prompt))
(set-marker cider-repl-prompt-start-mark prompt-start)
prompt-start))))
(defun cider-repl--ansi-color-apply (string)
"Like `ansi-color-apply', but does not withhold non-SGR seqs found in STRING.
Workaround for Emacs bug#53808 whereby partial ANSI control seqs present in
the input stream may block the whole colorization process."
(let* ((result (ansi-color-apply string))
;; The STRING may end with a possible incomplete ANSI control seq which
;; the call to `ansi-color-apply' stores in the `ansi-color-context'
;; fragment. If the fragment is not an incomplete ANSI color control
;; sequence (aka SGR seq) though then flush it out and appended it to
;; the result.
(fragment-flush?
(when-let (fragment (and ansi-color-context (cadr ansi-color-context)))
(save-match-data
;; Check if fragment is indeed an SGR seq in the making. The SGR
;; seq is defined as starting with ESC followed by [ followed by
;; zero or more [:digit:]+; followed by one or more digits and
;; ending with m.
(when (string-match
(rx (sequence ?\e
(? (and (or ?\[ eol)
(or (+ (any (?0 . ?9))) eol)
(* (sequence ?\; (+ (any (?0 . ?9)))))
(or ?\; eol)))))
fragment)
(let* ((sgr-end-pos (match-end 0))
(fragment-matches-whole? (or (= sgr-end-pos 0)
(= sgr-end-pos (length fragment)))))
(when (not fragment-matches-whole?)
;; Definitely not an partial SGR seq, flush it out of
;; `ansi-color-context'.
t)))))))
(if (not fragment-flush?)
result
(progn
;; Temporarily replace the ESC char in the fragment so that is flushed
;; out of `ansi-color-context' by `ansi-color-apply' and append it to
;; the result.
(aset (cadr ansi-color-context) 0 ?\0)
(let ((result-fragment (ansi-color-apply "")))
(aset result-fragment 0 ?\e)
(concat result result-fragment))))))
(defvar-local cider-repl--ns-forms-plist nil
"Plist holding ns->ns-form mappings within each connection.")
(defun cider-repl--ns-form-changed-p (ns-form connection)
"Return non-nil if NS-FORM for CONNECTION changed since last eval."
(when-let* ((ns (cider-ns-from-form ns-form)))
(not (string= ns-form
(lax-plist-get
(buffer-local-value 'cider-repl--ns-forms-plist connection)
ns)))))
(defvar cider-repl--root-ns-highlight-template "\\_<\\(%s\\)[^$/: \t\n()]+"
"Regexp used to highlight root ns in REPL buffers.")
(defvar-local cider-repl--root-ns-regexp nil
"Cache of root ns regexp in REPLs.")
(defvar-local cider-repl--ns-roots nil
"List holding all past root namespaces seen during interactive eval.")
(defun cider-repl--cache-ns-form (ns-form connection)
"Given NS-FORM cache root ns in CONNECTION."
(with-current-buffer connection
(when-let* ((ns (cider-ns-from-form ns-form)))
;; cache ns-form
(setq cider-repl--ns-forms-plist
(lax-plist-put cider-repl--ns-forms-plist ns ns-form))
;; cache ns roots regexp
(when (string-match "\\([^.]+\\)" ns)
(let ((root (match-string-no-properties 1 ns)))
(unless (member root cider-repl--ns-roots)
(push root cider-repl--ns-roots)
(let ((roots (mapconcat
;; Replace _ or - with regexp pattern to accommodate "raw" namespaces
(lambda (r) (replace-regexp-in-string "[_-]+" "[_-]+" r))
cider-repl--ns-roots "\\|")))
(setq cider-repl--root-ns-regexp
(format cider-repl--root-ns-highlight-template roots)))))))))
(defvar cider-repl-spec-keywords-regexp
(concat
(regexp-opt '("In:" " val:"
" at:" "fails at:"
" spec:" "fails spec:"
" predicate:" "fails predicate:"))
"\\|^"
(regexp-opt '(":clojure.spec.alpha/spec"
":clojure.spec.alpha/value")
"\\("))
"Regexp matching clojure.spec `explain` keywords.")
(defun cider-repl-highlight-spec-keywords (string)
"Highlight clojure.spec `explain` keywords in STRING.
Foreground of `clojure-keyword-face' is used for highlight."
(cider-add-face cider-repl-spec-keywords-regexp
'clojure-keyword-face t nil string)
string)
(defun cider-repl-highlight-current-project (string)
"Fontify project's root namespace to make stacktraces more readable.
Foreground of `cider-stacktrace-ns-face' is used to propertize matched
namespaces. STRING is REPL's output."
(cider-add-face cider-repl--root-ns-regexp 'cider-stacktrace-ns-face
t nil string)
string)
(defun cider-repl-add-locref-help-echo (string)
"Set help-echo property of STRING to `cider-locref-help-echo'."
(put-text-property 0 (length string) 'help-echo 'cider-locref-help-echo string)
string)
(defvar cider-repl-preoutput-hook `(,(if (< emacs-major-version 29)
'cider-repl--ansi-color-apply
'ansi-color-apply)
cider-repl-highlight-current-project
cider-repl-highlight-spec-keywords
cider-repl-add-locref-help-echo)
"Hook run on output string before it is inserted into the REPL buffer.
Each functions takes a string and must return a modified string. Also see
`cider-run-chained-hook'.")
(defcustom cider-repl-buffer-size-limit nil
"The max size of the REPL buffer.
Setting this to nil removes the limit."
:group 'cider
:type 'integer
:package-version '(cider . "0.26.0"))
(defun cider-start-of-next-prompt (point)
"Return the position of the first char of the next prompt from POINT."
(let ((next-prompt-or-input (next-single-char-property-change point 'field)))
(if (eq (get-char-property next-prompt-or-input 'field) 'cider-repl-prompt)
next-prompt-or-input
(next-single-char-property-change next-prompt-or-input 'field))))
(defun cider-repl-trim-top-of-buffer (buffer)
"Trims REPL output from beginning of BUFFER.
Trims by one fifth of `cider-repl-buffer-size-limit'.
Also clears remaining partial input or results."
(with-current-buffer buffer
(let* ((to-trim (ceiling (* cider-repl-buffer-size-limit 0.2)))
(start-of-next-prompt (cider-start-of-next-prompt to-trim))
(inhibit-read-only t))
(cider-repl--clear-region (point-min) start-of-next-prompt))))
(defun cider-repl-trim-buffer ()
"Trim the currently visited REPL buffer partially from the top.
See also `cider-repl-clear-buffer'."
(interactive)
(if cider-repl-buffer-size-limit
(cider-repl-trim-top-of-buffer (current-buffer))
(user-error "The variable `cider-repl-buffer-size-limit' is not set")))
(defun cider-repl-maybe-trim-buffer (buffer)
"Clear portion of printed output in BUFFER.
Clear the part where `cider-repl-buffer-size-limit' is exceeded."
(when (> (buffer-size) cider-repl-buffer-size-limit)
(cider-repl-trim-top-of-buffer buffer)))
(defun cider-repl--emit-output (buffer string face)
"Using BUFFER, emit STRING as output font-locked using FACE.
Before inserting, run `cider-repl-preoutput-hook' on STRING."
(with-current-buffer buffer
(save-excursion
(cider-save-marker cider-repl-output-start
(goto-char cider-repl-output-end)
(setq string (propertize string
'font-lock-face face
'rear-nonsticky '(font-lock-face)))
(setq string (cider-run-chained-hook 'cider-repl-preoutput-hook string))
(insert-before-markers string))
(when (and (= (point) cider-repl-prompt-start-mark)
(not (bolp)))
(insert-before-markers "\n")
(set-marker cider-repl-output-end (1- (point))))))
(when-let* ((window (get-buffer-window buffer t)))
;; If the prompt is on the first line of the window, then scroll the window
;; down by a single line to make the emitted output visible.
(when (and (pos-visible-in-window-p cider-repl-prompt-start-mark window)
(< 1 cider-repl-prompt-start-mark)
(not (pos-visible-in-window-p (1- cider-repl-prompt-start-mark) window)))
(with-selected-window window
(scroll-down 1)))))
(defun cider-repl--emit-interactive-output (string face)
"Emit STRING as interactive output using FACE."
(cider-repl--emit-output (cider-current-repl) string face))
(defun cider-repl-emit-interactive-stdout (string)
"Emit STRING as interactive output."
(cider-repl--emit-interactive-output string 'cider-repl-stdout-face))
(defun cider-repl-emit-interactive-stderr (string)
"Emit STRING as interactive err output."
(cider-repl--emit-interactive-output string 'cider-repl-stderr-face))
(defun cider-repl-emit-stdout (buffer string)
"Using BUFFER, emit STRING as standard output."
(cider-repl--emit-output buffer string 'cider-repl-stdout-face))
(defun cider-repl-emit-stderr (buffer string)
"Using BUFFER, emit STRING as error output."
(cider-repl--emit-output buffer string 'cider-repl-stderr-face))
(defun cider-repl-emit-prompt (buffer)
"Emit the REPL prompt into BUFFER."
(with-current-buffer buffer
(save-excursion
(cider-repl--insert-prompt cider-buffer-ns))))
(defun cider-repl-emit-result (buffer string show-prefix &optional bol)
"Emit into BUFFER the result STRING and mark it as an evaluation result.
If SHOW-PREFIX is non-nil insert `cider-repl-result-prefix' at the beginning
of the line. If BOL is non-nil insert at the beginning of the line."
(with-current-buffer buffer
(save-excursion
(cider-save-marker cider-repl-output-start
(goto-char cider-repl-output-end)
(when (and bol (not (bolp)))
(insert-before-markers "\n"))
(when show-prefix
(insert-before-markers (propertize cider-repl-result-prefix 'font-lock-face 'font-lock-comment-face)))
(if cider-repl-use-clojure-font-lock
(insert-before-markers (cider-font-lock-as-clojure string))
(cider-propertize-region
'(font-lock-face cider-repl-result-face rear-nonsticky (font-lock-face))
(insert-before-markers string)))))))
(defun cider-repl-newline-and-indent ()
"Insert a newline, then indent the next line.
Restrict the buffer from the prompt for indentation, to avoid being
confused by strange characters (like unmatched quotes) appearing
earlier in the buffer."
(interactive)
(save-restriction
(narrow-to-region cider-repl-prompt-start-mark (point-max))
(insert "\n")
(lisp-indent-line)))
(defun cider-repl-indent-and-complete-symbol ()
"Indent the current line and perform symbol completion.
First indent the line. If indenting doesn't move point, complete
the symbol."
(interactive)
(let ((pos (point)))
(lisp-indent-line)
(when (= pos (point))
(if (save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t))
(completion-at-point)))))
(defun cider-repl-kill-input ()
"Kill all text from the prompt to point."
(interactive)
(cond ((< (marker-position cider-repl-input-start-mark) (point))
(kill-region cider-repl-input-start-mark (point)))
((= (point) (marker-position cider-repl-input-start-mark))
(cider-repl-delete-current-input))))
(defun cider-repl--input-complete-p (start end)
"Return t if the region from START to END is a complete sexp."
(save-excursion
(goto-char start)
(cond ((looking-at-p "\\s *[@'`#]?[(\"]")
(ignore-errors
(save-restriction
(narrow-to-region start end)
;; Keep stepping over blanks and sexps until the end of
;; buffer is reached or an error occurs. Tolerate extra
;; close parens.
(cl-loop do (skip-chars-forward " \t\r\n)")
until (eobp)
do (forward-sexp))
t)))
(t t))))
(defun cider-repl--display-image (buffer image &optional show-prefix bol)
"Insert IMAGE into BUFFER at the current point.
For compatibility with the rest of CIDER's REPL machinery, supports
SHOW-PREFIX and BOL."
(with-current-buffer buffer
(save-excursion
(cider-save-marker cider-repl-output-start
(goto-char cider-repl-output-end)
(when (and bol (not (bolp)))
(insert-before-markers "\n"))
(when show-prefix
(insert-before-markers
(propertize cider-repl-result-prefix 'font-lock-face 'font-lock-comment-face)))
;; The below is inlined from `insert-image' and changed to use
;; `insert-before-markers' rather than `insert'
(let ((start (point))
(props (nconc `(display ,image rear-nonsticky (display))
(when (boundp 'image-map)
`(keymap ,image-map)))))
(insert-before-markers " ")
(add-text-properties start (point) props)))))
t)
(defcustom cider-repl-image-margin 10
"Specifies the margin to be applied to images displayed in the REPL.
Either a single number of pixels - interpreted as a symmetric margin, or
pair of numbers `(x . y)' encoding an arbitrary margin."
:type '(choice integer (vector integer integer))
:package-version '(cider . "0.17.0"))
(defun cider-repl--image (data type datap)
"A helper for creating images with CIDER's image options.
DATA is either the path to an image or its base64 coded data. TYPE is a
symbol indicating the image type. DATAP indicates whether the image is the
raw image data or a filename. Returns an image instance with a margin per
`cider-repl-image-margin'."
(create-image data type datap
:margin cider-repl-image-margin))
(defun cider-repl-handle-jpeg (_type buffer image &optional show-prefix bol)
"A handler for inserting a jpeg IMAGE into a repl BUFFER.
Part of the default `cider-repl-content-type-handler-alist'."
(cider-repl--display-image buffer
(cider-repl--image image 'jpeg t)
show-prefix bol))
(defun cider-repl-handle-png (_type buffer image &optional show-prefix bol)
"A handler for inserting a png IMAGE into a repl BUFFER.
Part of the default `cider-repl-content-type-handler-alist'."
(cider-repl--display-image buffer
(cider-repl--image image 'png t)
show-prefix bol))
(defun cider-repl-handle-svg (_type buffer image &optional show-prefix bol)
"A handler for inserting an svg IMAGE into a repl BUFFER.
Part of the default `cider-repl-content-type-handler-alist'."
(cider-repl--display-image buffer
(cider-repl--image image 'svg t)
show-prefix bol))
(defun cider-repl-handle-external-body (type buffer _ &optional _show-prefix _bol)
"Handler for slurping external content into BUFFER.
Handles an external-body TYPE by issuing a slurp request to fetch the content."
(if-let* ((args (cadr type))
(access-type (nrepl-dict-get args "access-type")))
(nrepl-send-request
(list "op" "slurp" "url" (nrepl-dict-get args access-type))
(cider-repl-handler buffer)
(cider-current-repl)))
nil)
(defvar cider-repl-content-type-handler-alist
`(("message/external-body" . ,#'cider-repl-handle-external-body)
("image/jpeg" . ,#'cider-repl-handle-jpeg)
("image/png" . ,#'cider-repl-handle-png)
("image/svg+xml" . ,#'cider-repl-handle-svg))
"Association list from content-types to handlers.
Handlers must be functions of two required and two optional arguments - the
REPL buffer to insert into, the value of the given content type as a raw
string, the REPL's show prefix as any and an `end-of-line' flag.
The return value of the handler should be a flag, indicating whether or not
the REPL is ready for a prompt to be displayed. Most handlers should return
t, as the content-type response is (currently) an alternative to the
value response. However for handlers which themselves issue subsequent
nREPL ops, it may be convenient to prevent inserting a prompt.")
(defun cider-repl-handler (buffer)
"Make an nREPL evaluation handler for the REPL BUFFER."
(let ((show-prompt t))
(nrepl-make-response-handler
buffer
(lambda (buffer value)
(cider-repl-emit-result buffer value t))
(lambda (buffer out)
(cider-repl-emit-stdout buffer out))
(lambda (buffer err)
(cider-repl-emit-stderr buffer err))
(lambda (buffer)
(when show-prompt
(cider-repl-emit-prompt buffer))
(when cider-repl-buffer-size-limit
(cider-repl-maybe-trim-buffer buffer)))
nrepl-err-handler
(lambda (buffer value content-type)
(if-let* ((content-attrs (cadr content-type))
(content-type* (car content-type))
(handler (cdr (assoc content-type*
cider-repl-content-type-handler-alist))))
(setq show-prompt (funcall handler content-type buffer value nil t))
(cider-repl-emit-result buffer value t t)))
(lambda (buffer warning)
(cider-repl-emit-stderr buffer warning)))))
(defun cider--repl-request-map (right-margin)
"Map to be merged into REPL eval requests.
RIGHT-MARGIN is as in `cider--nrepl-print-request-map'."
(map-merge 'hash-table
(cider--nrepl-print-request-map right-margin)
(unless cider-repl-use-pretty-printing
'(("nrepl.middleware.print/print" "cider.nrepl.pprint/pr")))
(when cider-repl-use-content-types
(cider--nrepl-content-type-map))))