diff --git a/arc.arc b/arc.arc index 5a6833e57..adf3f5c85 100644 --- a/arc.arc +++ b/arc.arc @@ -36,6 +36,13 @@ If you find others, please report them at http://arclanguage.org/forum. (assign source-file* (table)) (assign source* (table)) (assign help* (table)) +(assign original-stdin* (stdin)) +(assign original-stdout* (stdout)) +(assign original-stderr* (stderr)) + +(assign dbg (annotate 'mac + (fn ((o expr 'nil)) + `(debugger (lexenv) ',expr)))) (assign remac (annotate 'mac (fn (name parms . body) diff --git a/lib/colors.arc b/lib/colors.arc new file mode 100644 index 000000000..1d0cc2c77 --- /dev/null +++ b/lib/colors.arc @@ -0,0 +1,162 @@ + +(def cat args + (apply string "" args)) + +(def scat args + (sym:cat args)) + + +(= term* + (obj colors (obj + black 0 + red 1 + green 2 + yellow 3 + blue 4 + magenta 5 + cyan 6 + white 7) + attrs (obj + off 0 + reset 0 + rst 0 + bold 1 nobold 22 + bld 1 nobld 22 + ul 4 noul 24 + underline 4 nounderline 24 + blink 5 noblink 25 + black 30 fgblack 30 bgblack 40 + blk 30 fgblk 30 bgblk 40 + red 31 fgred 31 bgred 41 + green 32 fggreen 32 bggreen 42 + grn 32 fggrn 32 bggrn 42 + yellow 33 fgyellow 33 bgyellow 43 + ylw 33 fgylw 33 bgylw 43 + blue 34 fgblue 34 bgblue 44 + blu 34 fgblu 34 bgblu 44 + magenta 35 fgmagenta 35 bgmagenta 45 + mag 35 fgmag 35 bgmag 45 + cyan 36 fgcyan 36 bgcyan 46 + cyn 36 fgcyn 36 bgcyn 46 + white 37 fgwhite 37 bgwhite 47 + wht 37 fgwht 37 bgwht 47))) + +(def denil (xs) + (keep ~no xs)) + +(def windows () nil) + +(def prcode (codes (o sep #\;)) + (unless (windows) + (let xs (flat:list codes) + (pr (cat "\033[" (apply cat (intersperse sep denil.xs)) "m"))))) + + +(def lerp (a b vt) + ;(w/infix vt `* (b `- a) `+ a)) + (+ a (* vt (- b a)))) + +(def rgb16 (r g b (o bg nil)) + (+ 16 (* 36 (trunc:lerp 0 6 (/ r 256.0))) + (* 6 (trunc:lerp 0 6 (/ g 256.0))) + (trunc:lerp 0 6 (/ b 256.0)))) + +(def termval (val) + (term*!attrs val)) + +(def termfx fxs + (when (some [in (type _) 'int 'num] fxs) + (= fxs (list fxs))) + (each val fxs + (if (acons val) + (if (is len.val 3) (apply termrgb val) + (caris val 'fg) (apply termrgb (cdr val)) + (caris val 'bg) (apply termrgb (+ (cdr val) '(t))) + (err "termfx: unknown spec" val)) + (prcode (term*!attrs val))))) + +(def termrgb (r g b (o bg)) + (prcode (list (if bg 48 38) 5 (rgb16 r g b)))) + +(def prcol (col s) + (pr (cat "\033[1;" (string (+ 40 (term*!colors col))) "m")) + (pr s) + (pr "\033[1;0m") + s) + +(def prfx (spec . vals) + (after + (do (apply termfx (flat:list spec)) + (apply pr vals)) + (termfx nil))) + +(def prnfx args + (apply prfx args) + (prn)) + +(def mkfx args + (tostring:apply prfx args)) + +(mac w/fx (spec . vals) + (let f (afn (xs) + (when xs + (let x (car xs) + (cons + (if (and (acons x) (caris x 'unquote)) + (cadr x) + (list 'quote x)) + (self (cdr xs)))))) + `(tostring (prfx ',spec (cat ,@(intersperse #\space (f vals))))))) + + +(mac w/colors (var . body) + `(each ,var '(blk red grn ylw blu mag cyn wht) + (let ,(scat 'bg var) (scat 'bg ,var) + ,@body))) + +(mac w/attrs (var . body) + `(each ,var `(() (bold) (ul) (bold ul) (bold ul blink)) + ,@body)) + +(def prstyles (x) + (w/attrs attrs + (prfx attrs x) + (prn " ") + (w/colors col + (prfx `( ,col ,@attrs) x) (pr " ") + (prfx `(,bgcol ,@attrs) x) (pr " ") + (w/colors fg + (prfx `(,bgcol ,fg ,@attrs) x) (pr " ")) + (prn)) + (prn))) + + +(def makeprs (colors) + (accum a + (each col colors + (a `(def ,(scat 'pr col) (s) (prcol ',col s))) + (a `(def ,(scat 'prn col) (s) (prcol ',col s) (prn))) + (a `(def ,(scat 'mk col) (s) (tostring:prcol ',col s)))))) + +(mac evaldo (code) + `(eval `(do ,@(,@code)))) + +(evaldo:makeprs (keys term*!colors)) + +(def highlight (val str) + (replace val (mkred val) str)) + +(mac w/highlight (val . body) + `(let str (tostring (do ,@body)) + (void:pr (highlight ,val str)))) + +(def replace (old new str (o start 0)) + (iflet i (posmatch old str start) + (let s (+ (cut str 0 i) + new + (cut str (+ i (len old)))) + (replace old new s (+ i (len new)))) + str)) + + + diff --git a/lib/dbg.arc b/lib/dbg.arc new file mode 100644 index 000000000..1ac3b77a2 --- /dev/null +++ b/lib/dbg.arc @@ -0,0 +1,188 @@ +(= *debug nil + *env (obj)) + +(def *envwipe () + (each k (keys *env) + (wipe (*env k)))) + +(def tlread (prompt) + (w/stdout original-stdout* + (w/stdin original-stdin* + (disp prompt) + (flushout) + (read)))) + +(def tlerr (c) + (prn (details c)) + c) + +(def dbg-stats () + (pp (sorted (map [list _.1 _.0] (tablist *fncounts))))) + +(def dbg-wipestats () + (each k (keys *fncounts) + (= (*fncounts k) nil))) + +(def dbg-exnenv (env c) + (catch + (each x (stacktrace c) + (if (env x) + (throw (env x)))) + nil)) + +(assign exn* nil) +(assign dbgexpr* nil) + +(def dbg-restore (tbl) + (when tbl + (*envwipe) + (maptable (fn (k v) (sref *env v k)) tbl) + *env)) + +(def dbg-copy (tbl) + (let new (table) + (maptable (fn (k v) (sref new v k)) tbl) + new)) + +(def dbg-copyenv () + (dbg-copy *env)) + +(def call-w/dbg (f) + (if *debug + (f) + (let prev (dbg-copyenv) + (*envwipe) + (assign *debug t) + (after + ;(f) + (on-err (fn (c) (let name (*fn) + (let e (dbg-copyenv) + (w/pushnew c exn* + (dbg-restore e) + (debugger c))))) + ;(if (~posmatch "cannot reference undefined identifier" (details c)) + ; (debugger c) + ; (tlerr c))))) + f) + (do + (dbg-restore prev) + (assign *debug nil)))))) + +(def pprint (x) + (seval!pretty-print x) + x) + +(mac w/dbg body + `(call-w/dbg (fn () ,@body))) + +(def dbg-pps xs + (apply string + (intersperse #\space + (map [trim:tostring:pprint _] xs)))) + +(def dbg-slot (slot) + (when (>= len.slot 2) + (list slot.0 (if (is (type slot.1) 'fn) + (slot.1) + slot.1)))) + +(def dbg-locals (lenv) + (map dbg-slot lenv)) + +(def dbg-prn (lenv retexpr) + (when (> (len exn*) 0) + (tlerr (car exn*))) + ;(iflet stack (stacktrace) ;(at (stacktrace) 0 (pos 'dbg-prn (stacktrace))) + ; (prn "debugging at: " (dbg-pps (nthcdr (+ (pos 'debugger stack) 1) stack)))) + (whenlet trace (assoc '*stacktrace lenv) + (prn "debugging at: " (dbg-pps (dbg-slot trace)))) + (pr "locals:") + (each (name val) (dbg-locals lenv) + (prn) + (prblue name) + (pr " " (dbg-pps val))) + (prn) + (prn "type 'h to see this printout") + (prn "type 'c to continue") + (when retexpr + (pr "type 'v to see value of ") (prnblue (dbg-pps retexpr)))) + +(assign dbgenv* nil) + +(def dbg-eval (e expr lenv) + (let prev (dbg-copy e) + (assign dbgenv* (dbg-copyenv)) + (dbg-restore e) + (eval expr lenv))) + +(def dbg-prexpr (e lenv expr (o printer) (o o (stdout)) (o i (stdin))) + (let result (w/stdout o (w/stdin i (dbg-eval e expr lenv))) + (if printer + (printer expr result) + (prnred (dbg-pps result))) + (= thatexpr expr) + (= that result) + result)) + +;(def dbgerr (c) +; (prn:details c) +; (map pp stacktrace.c) +; (map pp fulltrace.c) +; c) + +(assign dbgerr debugger:tlerr) + +(def debugger (lenv (o retexpr) (o o (stdout)) (o i (stdin))) + (w/stdin original-stdin* + (w/stdout original-stdout* + (let e (dbg-copy (or dbgenv* *env)) + (dbg-restore e) + (assign dbgenv* nil) + (assign *debug nil) + (when (is (type lenv) 'exception) + ;(= lenv (lexenv lenv))) + (= lenv (dbg-exnenv e lenv))) + (when (is (type lenv) 'sym) + (= lenv (e lenv))) + (when (is (type lenv) 'fn) + (= lenv (lenv))) + (dbg-prn lenv retexpr) + (let done nil + ((afn () + (on-err (fn (c) + ;(dbgerr c) + (if *debug + (w/pushnew c exn* + (debugger c)) + (do + (tlerr c) + (if done + nil + (self))))) + (fn () + (let expr (tlread "> ") + (assign dbgexpr* expr) + (if (iso expr ''c) + (do (= done t) + (dbg-prexpr e lenv retexpr + (fn (expr result) + (when expr + (prnblue (dbg-pps expr)) + (pr " returned ") + (prnred (dbg-pps result)))) + o i)) + (iso expr ''v) + (do (dbg-prexpr e lenv retexpr) + (self)) + (iso expr ''h) + (do (dbg-prn lenv retexpr) + (self)) + (do (prnred (dbg-pps (dbg-eval e expr lenv))) + (if (iso dbgexpr* ''c) + (do + (assign dbgexpr* nil) + (dbg-prn lenv retexpr))) + (self))))))))))))) + + + diff --git a/libs.arc b/libs.arc index a31a4f57e..ab2a90939 100644 --- a/libs.arc +++ b/libs.arc @@ -2,6 +2,8 @@ (require '( ; core + lib/colors.arc + lib/dbg.arc lib/strings.arc lib/re.arc lib/binary.arc