/
core.cljc
1426 lines (1294 loc) · 56.5 KB
/
core.cljc
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
(ns farolero.core
"Common Lisp style handlers and restarts for errors."
(:require
[clojure.spec.alpha :as s]
[clojure.set :as set]
#?@(:clj ([net.cgrand.macrovich :as macros]
[clojure.stacktrace :as st])
:cljs ([goog.string :as gstring]
[goog.string.format])))
#?(:clj
(:import
(farolero.signal Signal))
:cljs
(:require-macros
[farolero.core :refer [restart-case wrap-exceptions]]
[net.cgrand.macrovich :as macros]))
(:refer-clojure :exclude [assert]))
(defprotocol Jump
"Internal protocol for jumping to locations for restarts."
(args [_]
"Returns an argument list used in the construction of the [[Jump]].")
(is-target? [_ v]
"Checks to see if the value is this jump's target."))
(macros/case :clj
(extend-protocol Jump
Signal
(args [this]
(.args this))
(is-target? [this target]
(= (.target this) target)))
:cljs
(defrecord Signal [target args]
Jump
(args [_] args)
(is-target? [_ v] (= target v))))
(declare error)
(def ^:dynamic *bound-blocks*
"A set of blocks that the code is currently in the dynamic scope of."
#{})
(defn block*
"Calls `f`, so that it may be escaped by calling [[return-from]], passing `block-name`.
This is analogous to Common Lisp's `catch` operator, with [[return-from]]
being passed a keyword directly replacing `throw`."
{:style/indent 2}
[block-name f & more]
(try (binding [*bound-blocks* (conj *bound-blocks* [#?(:clj (Thread/currentThread)
:cljs :unsupported)
block-name])]
(apply f more))
(catch #?(:clj farolero.signal.Signal
:cljs js/Object) e
(if
#_{:clj-kondo/ignore #?(:clj [:single-logical-operand] :cljs [])}
(and #?(:cljs (satisfies? Jump e))
(is-target? e block-name))
(first (args e))
(throw e)))))
(s/fdef block*
:args (s/cat :block-name keyword?
:f ifn?
:more (s/* any?)))
(defn make-jump-target
"INTERNAL: Constructs a new [[gensym]]med keyword used as the target of a jump."
[]
(keyword "farolero.core" (name (gensym "jump-target"))))
(s/fdef make-jump-target
:ret keyword?)
(macros/deftime
(defmacro block
"Constructs a named block which can be escaped by [[return-from]]."
{:style/indent 1}
[block-name & body]
(if (keyword? block-name)
`(block* ~block-name
(fn [] ~@body))
`(let [~block-name (make-jump-target)]
(block* ~block-name
(fn [] ~@body))))))
(s/fdef block
:args (s/cat :block-name (s/or :lexical symbol?
:dynamic keyword?)
:body (s/* any?)))
(defn make-jump
"INTERNAL: Constructs an implementation of [[Jump]]."
[target args]
(macros/case
:clj (Signal. target args)
:cljs (->Signal target args)))
(s/fdef make-jump
:args (s/cat :target keyword?
:args (s/coll-of any?))
:ret keyword?)
(defn return-from
"Performs an early return from a named [[block]]."
{:style/indent 1}
([block-name] (return-from block-name nil))
([block-name value]
(when-not (contains? *bound-blocks* [#?(:clj (Thread/currentThread)
:cljs :unsupported)
block-name])
(error ::control-error
:type ::outside-block))
(throw (make-jump block-name (list value)))))
(s/fdef return-from
:args (s/cat :block-name keyword?
:value (s/? any?)))
(def ^:dynamic *in-tagbodies*
"A set of tagbody blocks in the current dynamic scope."
#{})
(s/def ::tagbody-args (s/cat :initial-expr (s/* (comp not symbol?))
:clauses (s/* (s/cat :clause-tag symbol?
:clause-body (s/* (comp not symbol?))))))
(s/def ::jump-target keyword?)
(s/def ::clause-index number?)
(macros/deftime
(defmacro tagbody
"Performs the clauses in order, returning nil, allowing [[go]] between clauses.
Each clause is in the following form:
tag forms*
The tag is a symbol naming the clause. Optionally any number of forms may be
placed before the first tag, and these will execute first, although there is
no way to jump to them after their execution."
[& clauses]
(let [clauses (s/conform ::tagbody-args clauses)
init (not-empty (:initial-expr clauses))
clauses (concat (when init
[{:clause-tag (gensym)
:clause-body init}])
(:clauses clauses))
tags (map :clause-tag clauses)
target (make-jump-target)
go-targets (map-indexed (fn [idx tag]
[tag
{:jump-target target
:clause-index idx}])
tags)
clauses (map-indexed (fn [idx clause]
[idx
`(do ~@(:clause-body clause)
~(inc idx))])
clauses)
end (count clauses)]
(when (pos? end)
`(let [~@(mapcat identity go-targets)]
(binding [*in-tagbodies* (conj *in-tagbodies* ~target)]
(loop [control-pointer# 0]
(let [next-ptr#
(block ~target
(case control-pointer#
~@(mapcat identity clauses)
(error ::control-error
:type ::invalid-clause
:clause-number control-pointer#)))]
(when (not= next-ptr# ~end)
(recur next-ptr#))))))))))
(s/fdef tagbody
:args ::tagbody-args)
(defn go
"Jumps to the given `tag` in the surrounding [[tagbody]]."
[tag]
(when-not (contains? *in-tagbodies* (:jump-target tag))
(error ::control-error
:type ::outside-block))
(return-from (:jump-target tag) (:clause-index tag)))
(s/fdef go
:args (s/cat :tag (s/keys :req-un [::jump-target ::clause-index])))
(def ^:dynamic *extra-values*
"Dynamic variable for returning multiple values up the stack."
::unbound)
(macros/deftime
(defmacro multiple-value-bind
"Binds multiple return values.
Additional return values can be provided by [[values]]."
{:style/indent 1}
[[binding expr] & body]
`(let [expr-fn# (fn [] ~expr)
~binding (if (= ::unbound *extra-values*)
(binding [*extra-values* '()]
(cons (expr-fn#) *extra-values*))
(cons (expr-fn#) *extra-values*))]
~@body)))
(s/fdef multiple-value-bind
:args (s/cat :bindings (s/spec (s/cat :binding any?
:expr any?))
:body (s/* any?)))
(macros/deftime
(defmacro multiple-value-list
"Returns the multiple values from `expr` as a list."
[expr]
`(multiple-value-bind [ret# ~expr]
ret#)))
(s/fdef multiple-value-list
:args (s/cat :expr any?))
(macros/deftime
(defmacro multiple-value-call
"Calls `f` with all the values returned by each of the `forms`."
{:style/indent 1}
[f & forms]
`(apply ~f
(mapcat identity
~(cons 'list (map (fn [expr] `(multiple-value-list ~expr)) forms))))))
(s/fdef multiple-value-call
:args (s/cat :function any?
:args (s/* any?)))
(macros/deftime
(defmacro values
"Returns multiple values.
The first value is the \"true\" return value. Additional values may be bound
using [[multiple-value-bind]].
Because of limitations on which values can hold metadata, the additional
values are not actually associated with the primary return value, and are
instead held in [[*extra-values*]]. This means if a [[multiple-value-bind]] or
other methods of getting the extra values is done on a call which does not
return multiple values, it may \"leak\" multiple values which were returned by
some call within its dynamic extent but whose value was not returned."
[value & more]
`(let [ret# ~value]
(when-not (= ::unbound *extra-values*)
(set! *extra-values* ~(cons 'list more)))
ret#)))
(s/fdef values
:args (s/cat :value any?
:more (s/* any?)))
(defn values-list
"Returns the input list as multiple values."
[values]
(when-not (= ::unbound *extra-values*)
(set! *extra-values* (rest values)))
(first values))
(s/fdef values-list
:args (s/cat :values (s/coll-of any?))
:ret any?)
(def ^:dynamic *handlers*
"Dynamically-bound list of handlers."
'())
(s/def ::handler-key (s/nonconforming
(s/or :keyword keyword?
:class symbol?)))
(macros/deftime
(defmacro without-handlers
"Runs the `body` in a context where no handlers are bound.
Use with caution. It's incredibly rare that handlers should be completely
unbound when running a given bit of code.
The main intended usecase for this is to allow spinning up additional threads
without the bound handlers being used. Even in this context however, most of
the handlers which are undesirable to be run from alternate threads will be
marked as thread-local. If the only reason to unbind handlers is to prevent
calling a handler which may attempt to perform a non-local return, then this
macro should not be used."
[& body]
`(binding [*handlers* '()]
~@body)))
(s/fdef without-handlers
:args (s/cat :body (s/* any?)))
(macros/deftime
(defmacro handler-bind
"Runs the `body` with bound signal handlers to recover from errors.
Bindings are of the form:
condition-type handler-fn
Each binding clause is one of the following forms:
condition-type handler-fn
condition-type [handler-fn & {:keys [thread-local]}]
The condition-type must be a keyword, or a class name for the object used as
the condition. This is tested with `isa?`, permitting the use of Clojure
hierarchies. If it is a keyword, it's recommended to be namespaced. If it is a
class name, it checks if the [[type]] of the condition matches the
condition-type.
The handler-fn is a function of at least one argument. The first argument is
the condition which was signaled, additional arguments are passed from the
rest arguments used when signalling.
The thread-local configuration for a handler specifies whether or not other
threads are allowed to invoke this handler. It defaults to false. If the
handler performs any kind of non-local return, such as calling a restart that
performs non-local return, signals an error that might be handled with a
non-local return, or calls to [[return-from]] or [[go]], it should be set to
true.
If the handler returns normally, then additional handlers which apply to the
condition type are run in order of most specific to least until no more are
left. If all applicable handlers return normally, then signal function will
return normally as well."
{:arglists '([[bindings*] exprs*])
:style/indent 1}
[bindings & body]
(let [bindings (map (fn [[k f]]
(if-not (vector? f)
{::handler-fn f
::condition-type k}
(update
(set/rename-keys (assoc (apply hash-map (rest f))
::handler-fn (first f)
::condition-type k)
{:thread-local ::handler-thread})
::handler-thread
(fn [t]
(macros/case
:clj (when t
`(Thread/currentThread))
:cljs :unsupported)))))
(partition 2 bindings))]
`(binding [*handlers* (conj *handlers* ~(cons 'list bindings))]
~@body))))
(s/fdef handler-bind
:args (s/cat :bindings (s/and (s/* (s/cat :key ::handler-key
:handler (s/or :fn-with-opts vector?
:bare-fn any?)))
vector?)
:body (s/* any?)))
(defn jump-factory
"INTERNAL: Constructs a function body which throws to the passed `target`."
[block target]
`(fn [& args#]
(return-from ~block (cons ~target args#))))
(s/fdef jump-factory
:args (s/cat :block symbol?
:target keyword?))
(s/def ::handler-clause (s/cat :name ::handler-key
:arglist vector?
:body (s/* any?)))
(macros/deftime
(defmacro handler-case
"Runs the `expr` with signal handlers bound, returning the value from the handler on signal.
Bindings match the form from [[handler-bind]].
If a condition handled by one of this binding's clauses is signaled, the
stack is immediately unwound out of the context of `expr`, and then the
handler bound has its code run, with its return value used as a replacement
for the return value of the entire `expr`.
An additional clause which can be present is `:no-error`, which takes
arguments for the return values of the expression (multiple may be provded
with [[values]]), and it is only run when no condition handled by this clause
is signaled."
{:arglists '([expr bindings*])
:style/indent [1 :form [:defn]]}
[expr & bindings]
(let [bindings (map (partial s/conform ::handler-clause) bindings)
no-error-clause (first (filter (comp #{:no-error} :name) bindings))
no-error-fn `(fn ~(:arglist no-error-clause) ~@(:body no-error-clause))
bindings (filter (comp (complement #{:no-error}) :name) bindings)
case-block (gensym)
targets (repeatedly (count bindings) make-jump-target)
factories (map (fn [binding target]
[(:name binding) [(jump-factory case-block target) :thread-local true]])
bindings
targets)
clauses (map (fn [binding target]
[target `(fn ~(:arglist binding) ~@(:body binding))])
bindings
targets)
src (fn [block-target]
`(let [[case-clause# & args#]
(block ~case-block
(handler-bind [~@(mapcat identity factories)]
(return-from ~block-target ~expr)))]
(apply
(case case-clause#
~@(mapcat identity clauses)
(error ::control-error
:type ::invalid-clause))
args#)))
error-return (gensym "error-return")
normal-return (gensym "normal-return")]
(if no-error-clause
`(block ~error-return
(multiple-value-call ~no-error-fn
(block ~normal-return
(return-from ~error-return
~(src normal-return)))))
`(block ~normal-return
~(src normal-return))))))
(s/fdef handler-case
:args (s/and (s/cat :expr any?
:bindings (s/* (s/spec ::handler-clause)))
#(<= (count (filter (comp #{:no-error} :name) (:bindings %))) 1)))
(def ^:private throwing-restart
"A restart that throws the condition as an exception unconditionally."
{::restart-name ::throw
::restart-reporter "Throw the condition as an exception"
::restart-interactive (constantly nil)
::restart-fn (fn [& args]
(throw (ex-info "Condition was thrown"
(cond-> {}
(first args) (assoc :condition (first args))
(rest args) (assoc :arguments (rest args))))))})
(def ^:dynamic *restarts*
"Dynamically-bound list of restarts."
(list throwing-restart))
(macros/deftime
(defmacro without-restarts
"Runs the `body` in a context where no restarts are bound.
Use with caution. It's incredibly rare that restarts should be completely
unbound when running a given bit of code.
Most restarts that will be called will perform some kind of non-local return.
In those circumstances, the restarts will already not be visible to threads
other than the one that bound them. This means that the cases in which this
macro are necessary are incredibly rare, and should be carefully considered.
See [[without-handlers]]."
[& body]
`(binding [*restarts* (list throwing-restart)]
~@body)))
(s/fdef without-restarts
:args (s/cat :body (s/* any?)))
(s/def ::restart-name keyword?)
(s/def ::restart-fn ifn?)
(s/def ::restart-test ifn?)
(s/def ::restart-interactive ifn?)
(s/def ::restart-reporter ifn?)
(s/def ::restart-thread #?(:clj (partial instance? Thread)
:cljs keyword?))
(s/def ::restart (s/keys :req [::restart-name ::restart-fn]
:opt [::restart-test ::restart-interactive
::restart-reporter ::restart-thread]))
(macros/deftime
(defmacro restart-bind
"Runs the `body` with bound restarts.
Within the dynamic scope of the `body`, [[invoke-restart]] may be called with
any of the bound restart names. This includes inside handlers bound further up
the stack.
Each binding clause is one of the following forms:
restart-name restart-fn
restart-name [restart-fn & {:keys [test-function interactive-function report-function thread-local]}]
The restart-name can be any key for a map, but it is recommended to use a
namespaced keyword.
The restart-fn is a function of zero or more arguments, provided by rest
arguments on the call to [[invoke-restart]]. The function returns normally.
The test-function is a function of optional arguments for a condition and its
additional arguments. If it returns a truthy value, the restart is available,
otherwise it cannot be invoked from its context. If not provided, the restart
is assumed to be available.
The report-function is a function or string used to display this condition to
the user. If it is a function, it is called with the restart as an argument
and should return a string. If it is a string, it is used verbatim.
The boolean thread-local tells the system whether or not this restart may be
invoked from other threads. It defaults to false. If the restart performs any
kind of non-local return that cares about which thread performs it, such as a
call to [[return-from]] or [[go]], signaling a condition which may cause a
non-local return, or invoking a restart which may perform a lon-local return,
it should set it to true.
The interactive-function is a function of no arguments that is called to get
input from the user interactively. It returns a list, used as the argument
list to restart-fn."
{:arglists '([[bindings*] exprs*])
:style/indent 1}
[bindings & body]
(let [bindings (map (fn [[k f]]
(if-not (vector? f)
{::restart-fn f
::restart-name k}
(update
(set/rename-keys (assoc (apply hash-map (rest f))
::restart-fn (first f)
::restart-name k)
{:test-function ::restart-test
:interactive-function ::restart-interactive
:report-function ::restart-reporter
:thread-local ::restart-thread})
::restart-thread
(fn [t]
(macros/case
:clj (when t
`(Thread/currentThread))
:cljs :unsupported)))))
(reverse (partition 2 bindings)))]
`(binding [*restarts* (into *restarts* ~(cons 'list bindings))]
~@body))))
(s/fdef restart-bind
:args (s/cat :bindings
(s/and (s/* (s/cat
:key (s/nilable keyword?)
:restart (s/or :fn-with-opts vector?
:bare-fn any?)))
vector?)
:body (s/* any?)))
(s/def ::restart-clause (s/cat :name (s/nilable keyword?)
:arglist vector?
:restart-fns (s/* (s/cat :keyword keyword?
:function any?))
:body (s/* any?)))
(macros/deftime
(defmacro restart-case
"Runs the `expr` with bound restarts, returning a value from the restart on invoke.
Bindings match [[restart-bind]].
If one of the restarts bound in this case is invoked then the stack is
immediately unwound to outside of `expr`, and then the restart is run, with
its return value used as a replacement for its return value."
{:arglists '([expr bindings*])
:style/indent [1 :form [:defn]]}
[expr & bindings]
(let [bindings (map (partial s/conform ::restart-clause) bindings)
case-block (gensym)
targets (repeatedly (count bindings) make-jump-target)
factories (map (fn [binding target]
[(:name binding)
(apply vector (jump-factory case-block target)
:thread-local true
(mapcat identity
(set/rename-keys (into {}
(map (juxt :keyword :function)
(:restart-fns binding)))
{:test :test-function
:report :report-function
:interactive :interactive-function})))])
bindings
targets)
clauses (map (fn [binding target]
[target `(fn ~(:arglist binding) ~@(:body binding))])
bindings
targets)]
`(block return-block#
(let [[case-clause# & args#]
(block ~case-block
(restart-bind [~@(mapcat identity factories)]
(return-from return-block# ~expr)))]
(apply
(case case-clause#
~@(mapcat identity clauses)
(error ::control-error
:type ::invalid-clause))
args#))))))
(s/fdef restart-case
:args (s/cat :expr any?
:bindings (s/* (s/spec ::restart-clause))))
(macros/deftime
(defmacro with-simple-restart
"Constructs a restart with the given name which unwinds and returns nil.
Returns true as a second value with [[values]] when the restart was
triggered.
The `format-str` and `args` are used when reporting the restart."
[[restart-name format-str & args] & body]
`(restart-case (values (do ~@body) nil)
(~restart-name []
:report (fn [~'_] (wrap-exceptions
(~(macros/case
:clj `format
:cljs `goog.string/format) ~format-str ~@args)))
:interactive (constantly nil)
(values nil true)))))
(s/fdef with-simple-restart
:args (s/cat :restart-def (s/spec (s/cat :name (s/nilable keyword?)
:format-str any?
:args (s/* any?)))
:body (s/* any?)))
(s/def ::condition (s/or :keyword (s/and keyword?
namespace)
:other (complement keyword?)))
(defn handles-condition?
"Returns true if the given `handler` can handle the `condition`."
[condition handler]
(boolean
(or (isa? condition handler)
(isa? (type condition) handler))))
(s/fdef handles-condition?
:args (s/cat :condition ::condition
:handler (s/or :keyword keyword?
:class #?(:clj class?
:cljs any?)))
:ret boolean?)
(defn throwing-debugger
"A \"debugger\" that wraps conditions with [[ex-info]] and throws them.
If the condition is an exception and no further arguments are included, then
the condition is thrown directly instead."
[[condition & args] _]
(if (and (instance? #?(:clj Exception
:cljs js/Error)
condition)
(nil? (seq args)))
(throw condition)
(throw (ex-info "Unhandled condition" {:condition condition
:handlers (keys *handlers*)
:args args}
(when (instance? #?(:clj Throwable
:cljs js/Error)
condition)
condition)))))
(s/fdef throwing-debugger
:args (s/cat :raised (s/spec (s/cat :condition ::condition
:args (s/* any?)))
:hook ifn?))
(def ^:dynamic *debugger-hook*
"Dynamically-bound hook used in [[invoke-debugger]].
This is a function which takes two arguments, a list of the condition and
arguments to it, and the currently bound debugger hook. This function must not
return without a non-local exit."
throwing-debugger)
(macros/case :clj
(declare system-debugger))
(def ^:dynamic *system-debugger*
"The debugger used when [[*debugger-hook*]] is nil.
This happens when the error may have occurred in the debugger itself."
(macros/case
:clj system-debugger
:cljs throwing-debugger))
(macros/deftime
(defmacro wrap-exceptions
"Catching all exceptions from evaluating `body` and signals them as [[error]]s.
This only catches exceptions, meaning [[block]], [[tagbody]], conditions, and
restarts can all be handled through the dynamic scope of `body` without
issue."
{:style/indent 0}
[& body]
`(block outer-block#
(tagbody
eval#
(try (return-from outer-block#
(do ~@body))
(catch ~(macros/case :clj 'java.lang.Exception :cljs 'js/Error) e#
(return-from
outer-block#
(restart-case (error e#)
(::continue []
:report "Ignore the exception and retry evaluation"
:interactive (constantly nil)
(go eval#))
(::use-value [v#]
:report "Ignore the exception and use the passed value"
:interactive ~(if (:ns &env)
`(constantly nil)
`(comp list eval read))
v#)))))))))
(s/fdef wrap-exceptions
:args (s/cat :body (s/* any?)))
(defn invoke-debugger
"Calls the [[*debugger-hook*]], or a system debugger if not bound, with the `condition`.
In Clojure the default system debugger is [[system-debugger]]. In
ClojureScript it is [[throwing-debugger]]. This can be overriden by
binding [[*system-debugger*]]."
[condition & args]
(if *debugger-hook*
(let [hook *debugger-hook*]
(binding [*debugger-hook* nil]
(hook (cons condition args) hook)))
(*system-debugger* (cons condition args) *system-debugger*)))
(s/fdef invoke-debugger
:args (s/cat :condition ::condition
:args (s/* any?)))
(defn break
"Binds the system debugger and invokes it on the given condition."
[condition & args]
(binding [*debugger-hook* nil]
(let [[condition & args] (if (string? condition)
(concat (list ::simple-condition condition) args)
(cons condition args))]
(restart-case (apply invoke-debugger condition args)
(::continue [] :report "Continue out of the debugger" :interactive (constantly nil))))))
(s/fdef break
:args (s/cat :condition ::condition
:args (s/* any?)))
(def ^:dynamic *break-on-signals*
"Dynamically-bound type of signal to [[break]] on."
nil)
(derive ::simple-condition ::condition)
(defn signal
"Signals a condition, triggering handlers bound for the condition type.
Looks up the stack for handlers which apply to the given `condition` and then
applies them in sequence until they all complete or one calls
[[invoke-restart]]. If this function returns normally, it will return nil.
When [[*break-on-signals*]] is true, or `condition` matches it with [[isa?]],
calls [[break]] before executing the signal."
[condition & args]
(let [[condition & args] (if (string? condition)
(concat (list ::simple-condition condition) args)
(cons condition args))
condition-type (if (keyword? condition)
condition
(type condition))]
(when-not (or (contains? (ancestors condition-type) ::condition)
(= condition-type ::condition))
(derive condition-type ::condition))
(when (or (true? *break-on-signals*)
(isa? condition *break-on-signals*))
(break (str "Breaking on signal " (pr-str condition-type) ", called with arguments " (pr-str args))))
(loop [remaining-clusters *handlers*]
(when (seq remaining-clusters)
(binding [*handlers* (rest remaining-clusters)]
(let [cluster (first remaining-clusters)]
(doseq [{::keys [condition-type handler-fn handler-thread]} cluster
:when (handles-condition? condition condition-type)]
(when (or (= handler-thread #?(:clj (Thread/currentThread)
:cljs :unsupported))
(not handler-thread))
(apply handler-fn condition args)))))
(recur (rest remaining-clusters)))))
nil)
(s/fdef signal
:args (s/cat :condition ::condition
:args (s/* any?))
:ret nil?)
(defn report-restart
"Reports the restart using the its report-function."
[{:as restart ::keys [restart-name restart-reporter]}]
(if restart-reporter
(cond
(string? restart-reporter) restart-reporter
(ifn? restart-reporter) (wrap-exceptions
(restart-reporter restart)))
restart-name))
(s/fdef report-restart
:args (s/cat :restart ::restart))
(defmulti report-condition
"Multimethod for creating a human-readable explanation of a condition."
(fn [condition & _args]
(if (keyword? condition)
condition
(type condition))))
(s/fdef report-condition
:args (s/cat :condition ::condition
:args (s/* any?)))
(defmethod report-condition :default
[condition & args]
(str (pr-str (if (keyword? condition)
condition
(type condition)))
" was signaled with arguments "
(pr-str args)))
(macros/case
:clj (defmethod report-condition Exception
[condition & _args]
(ex-message condition))
:cljs
#_{:clj-kondo/ignore #?(:clj [:unresolved-namespace] :cljs [])}
(defmethod report-condition js/Error
[condition & _args]
(.-message condition)))
(macros/usetime
(defmethod report-condition ::simple-condition
[_ & [format-str & args]]
(if format-str
(wrap-exceptions
(apply #?(:clj format :cljs gstring/format) format-str args))
"A simple condition")))
(defmethod report-condition ::type-error
[_ type-description & {:keys [value spec]}]
(str "The value doesn't conform to spec " type-description
"\nSpec:" (pr-str spec)
"\nValue:" (pr-str value)))
(derive ::warning ::condition)
(derive ::simple-warning ::warning)
(derive ::simple-warning ::simple-condition)
(def ^:dynamic *warning-printer*
"Dynamically-bound function used to display a warning to the user.
This must be a varargs function taking a `condition` and additional arguments.
The function [[report-condition]] may be used to assist in generating the
error string.
The default value will write the condition to stderr, including any stack
trace on the condition if it is an exception type."
(fn [condition & args]
(binding #?(:clj [*out* *err*]
:cljs [*print-fn* *print-err-fn*])
(println "WARNING:" (apply report-condition condition args))
(when (instance? #?(:clj Throwable
:cljs js/Error)
condition)
#?(:clj (st/print-cause-trace condition)
:cljs (pr (.stack condition)))))))
(defn warn
"Signals a condition, printing a warning to [[*err*]] if not handled.
Binds a restart called `:farolero.core/muffle-warning`, which can be invoked
from any handlers to prevent the warning without any additional side effects.
This restart may be invoked directly by calling [[muffle-warning]].
The `condition` will be modified to derive from `:farolero.core/warning`. If
it is a keyword, it will derive directly, otherwise it will derive the type.
This allows general handlers of `:farolero.core/warning` to handle this
condition.
See [[signal]]."
[condition & args]
(let [[condition & args] (if (string? condition)
(concat (list ::simple-warning condition) args)
(cons condition args))
condition-type (if (keyword? condition)
condition
(type condition))]
(when-not (or (contains? (ancestors condition-type) ::warning)
(= condition-type ::warning))
(derive condition-type ::warning))
(restart-case (do (apply signal condition args)
(apply *warning-printer* condition args))
(::muffle-warning [] :report "Ignore the warning and continue" :interactive (constantly nil))))
nil)
(s/fdef warn
:args (s/cat :condition ::condition
:args (s/* any?))
:ret nil?)
(derive ::error ::condition)
(derive ::simple-error ::error)
(derive ::simple-error ::simple-condition)
(macros/case
:clj (derive Exception ::error)
:cljs (derive js/Error ::error))
(defn error
"Signals a condition, calling [[invoke-debugger]] if no handler is found.
See [[signal]]."
[condition & args]
(let [[condition & args] (if (string? condition)
(concat (list ::simple-error condition) args)
(cons condition args))
condition-type (if (keyword? condition)
condition
(type condition))]
(when-not (or (contains? (ancestors condition-type) ::error)
(= condition-type ::error))
(derive condition-type ::error))
(apply signal condition args)
(apply invoke-debugger condition args)))
(s/fdef error
:args (s/cat :condition ::condition
:args (s/* any?))
:ret nil?)
(defn cerror
"Signals a condition as [[error]], but binds a restart to continue.
The `:farolero.core/continue` restart is bound for any handlers invoked by
this error. This restart may be invoked directly by calling [[continue]].
`report-fmt` is used as the argument to `:report` in the resulting restart.
See [[signal]]."
([] (cerror "Ignore the error and continue"))
([report-fmt] (cerror report-fmt ::simple-error "An error has occurred"))
([report-fmt condition & args]
(restart-case (apply error condition args)
(::continue [] :report report-fmt :interactive (constantly nil)))))
(s/fdef cerror
:args (s/cat :report-fmt (s/? (s/or :function ifn?
:string string?))
:condition (s/? any?)
:args (s/* any?))
:ret nil?)
(defn compute-restarts
"Returns a sequence of all usable restarts.
Any restart with a `:farolero.core/restart-test` function will be filtered
based on if it returns a truthy value when called with `condition` and
`args`."
([] (compute-restarts nil))
([condition & args]
(filter #(and (or (= (::restart-thread %) #?(:clj (Thread/currentThread)
:cljs :unsupported))
(not (::restart-thread %)))
(wrap-exceptions
(apply (::restart-test % (constantly true)) condition args)))
*restarts*)))
(s/fdef compute-restarts
:args (s/cat :condition (s/? any?)
:args (s/* any?))
:ret (s/coll-of ::restart))
(defn find-restart
"Returns the first restart bound named by `restart-name`."
([restart-name] (find-restart restart-name nil))
([restart-name condition & args]
(first (filter (comp #{restart-name} ::restart-name) (apply compute-restarts condition args)))))
(s/fdef find-restart
:args (s/cat :restart-name ::restart-name
:condition (s/? any?)
:args (s/* any?))
:ret ::restart)
(defn invoke-restart
"Calls a restart by the given name with `args`.
If the restart isn't found, signals a `:farolero.core/control-error`.
Throws an assertion exception if called outside a restart context.
See [[restart-bind]], [[restart-case]]."
[restart-name & args]
(if-let [restart (if (keyword? restart-name)
(find-restart restart-name)
restart-name)]
(apply (::restart-fn restart) args)
(error ::control-error
:type ::missing-restart
:restart-name restart-name
:available-restarts (compute-restarts))))
(s/fdef invoke-restart
:args (s/cat :restart-name (s/or :name keyword?
:restart ::restart)
:args (s/* any?)))
(def ^:private interactive-lock
"An object used to ensure interactive restarts are invoked serially."
#?(:clj (Object.)
:cljs nil))
(defn invoke-restart-interactively
"Calls a restart by the given name interactively.
If the restart was created with an `:interactive-function`, then it is called
to produce the argument list for the restart. Otherwise, a default is used. In
Clojure, the default is to read and evaluate from [[*in*]]. In ClojureScript,
the default is to produce nil as the arguments.
See [[invoke-restart]]"
[restart-name]
(locking interactive-lock
(if-let [restart (if (keyword? restart-name)
(find-restart restart-name)
restart-name)]
(apply invoke-restart restart-name
((or (::restart-interactive restart)
#?(:clj #(restart-case (wrap-exceptions
(println (str "Provide an expression that"
" evaluates to the argument list"
" for the restart"))
(print (str (ns-name *ns*) "> "))
(flush)
(eval (read)))
(::abort [] :report "Abort making the argument list and use nil")
(::use-value [v] :report "Uses the passed value for the argument list"
v))
:cljs (constantly nil)))))
(error ::control-error
:type ::missing-restart
:restart-name restart-name
:available-restarts (compute-restarts)))))
(s/fdef invoke-restart-interactively
:args (s/cat :restart-name (s/or :name keyword?
:restart ::restart)))
(defn muffle-warning