/lib/trace.arc

 1; written by fallintothis
 2; stolen from from http://bitbucket.org/fallintothis/trace/src/tip/trace.arc
 3
 4; function & macro tracing
 5
 6(= trace-level* 0)
 7(= trace-indent* nil)
 8(= traced* (table))
 9
10(def traced (f (o name (fn-name f)))
11  (check-traceable f)
12  (let orig f
13    (annotate (type orig)
14      (fn args
15        (++ trace-level*)
16        (trace-enter name args)
17        (after (trace-exit name (apply (rep orig) args))
18               (-- trace-level*))))))
19
20(mac trace fs
21  `(do1 nil ,@(map (fn (f)
22                     `(if (no (traced* ',f))
23                          (do (prn "*** tracing " ',f)
24                              (make-traced ,f))
25                          (prn "*** already traced " ',f)))
26                   fs)))
27
28(mac make-traced (name)
29  (check-traceable-name name)
30  (w/uniq f
31    `(let ,f (traced ,name ',name)
32       (= (traced* ',name) ,name
33          ,name ,f))))
34
35(mac untrace fs
36  `(do1 nil ,@(map (fn (f)
37                     `(if (traced* ',f)
38                          (do (prn "*** untracing " ',f)
39                              (make-untraced ,f))
40                          (prn "*** already untraced " ',f)))
41                   (or fs (keys traced*)))))
42
43(mac make-untraced (name)
44  `(= ,name (traced* ',name)
45      (traced* ',name) nil))
46
47(def indent () (sp (indent-amount)))
48
49(def indent-amount ()
50  (* (or trace-indent* 0) (- trace-level* 1)))
51
52(def trace-enter (name args)
53  (indent)
54  (pr trace-level* ". Trace: ")
55  (pprn-elastic (cons name args)))
56
57(def trace-exit (name result)
58  (indent)
59  (pr trace-level* ". Trace: " name " ==> ")
60  (pprn-elastic result)
61  result)
62
63(def pprn-elastic (expr)
64  (let broke (w/stdout (outstring) (ppr expr))
65    (if broke (prn))
66    (ppr expr (if broke (indent-amount) 0)) ; xxx gross to redo ppr
67    (prn)))
68
69(def check-traceable-name (name)
70  (if (~isa name 'sym)
71      (err "Not a function or macro name:" name)
72      (~bound name)
73      (err "Can't trace unbound symbol:" name)))
74
75(def check-traceable (f)
76  (unless (in (type f) 'fn 'mac)
77    (err "Can only trace functions and macros:" f)))
78
79; gross, but more-or-less effective
80
81(def fn-name (f)
82  (let repr (tostring:disp (case (type f) fn f mac (rep f)))
83    (if (headmatch "#<procedure:" repr)
84        (sym:trim (cut repr 12 -1))
85        f))) ; ppr uses write, not disp, so (sym:tostring:disp f) has bars