├── sayid-logo.png ├── .gitignore ├── Makefile ├── .circleci └── config.yml ├── src ├── sayid │ └── plugin.clj └── com │ └── billpiel │ └── sayid │ ├── util │ ├── find_ns.clj │ ├── tree_query.clj │ └── other.clj │ ├── shelf.clj │ ├── sayid_multifn.clj │ ├── test1.html │ ├── view.clj │ ├── recording.clj │ ├── profiling.clj │ ├── workspace.clj │ ├── trace.clj │ ├── query2.clj │ ├── nrepl_middleware.clj │ ├── core.clj │ └── string_output2.clj ├── test └── com │ └── billpiel │ └── sayid │ ├── test_ns1.clj │ ├── recording_test.clj │ ├── test_utils.clj │ ├── workspace_test.clj │ ├── core_test.clj │ └── query_test.clj ├── project.clj ├── .dir-locals.el ├── CHANGELOG.md ├── LICENSE └── README.md /sayid-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/clojure-emacs/sayid/HEAD/sayid-logo.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | pom.xml 5 | pom.xml.asc 6 | *.jar 7 | *.class 8 | /.lein-* 9 | /.nrepl-port 10 | .hgignore 11 | .hg/ 12 | *.elc 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | VERSION:=0.1.0 2 | PACKAGE_NAME:=sayid-$(VERSION) 3 | PACKAGE_DIR:=/tmp/$(PACKAGE_NAME) 4 | 5 | package-el: 6 | mkdir $(PACKAGE_DIR) 7 | cp -r src/el/* $(PACKAGE_DIR) 8 | tar cvf ../$(PACKAGE_NAME).tar --exclude="*#" --exclude="*~" -C $(PACKAGE_DIR)/.. $(PACKAGE_NAME) 9 | rm -rf $(PACKAGE_DIR) 10 | 11 | # end 12 | -------------------------------------------------------------------------------- /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | 3 | references: 4 | base_config: &base_config 5 | working_directory: ~/sayid 6 | docker: 7 | - image: circleci/clojure:lein-2.9.1 8 | 9 | jobs: 10 | test: 11 | <<: *base_config 12 | steps: 13 | - checkout 14 | - run: lein test-all 15 | 16 | workflows: 17 | version: 2 18 | build: 19 | jobs: 20 | - test 21 | -------------------------------------------------------------------------------- /src/sayid/plugin.clj: -------------------------------------------------------------------------------- 1 | (ns sayid.plugin 2 | (:require 3 | [clojure.java.io :as io])) 4 | 5 | (def version 6 | "The current version of sayid as a string." 7 | (-> (or (io/resource "META-INF/leiningen/com.billpiel/sayid/project.clj") 8 | "project.clj") 9 | slurp 10 | read-string 11 | (nth 2))) 12 | 13 | (defn middleware 14 | [project] 15 | (-> project 16 | (update-in [:dependencies] 17 | (fnil into []) 18 | [['com.billpiel/sayid version]]) 19 | (update-in [:repl-options :nrepl-middleware] 20 | (fnil into []) 21 | ['com.billpiel.sayid.nrepl-middleware/wrap-sayid]))) 22 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/util/find_ns.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.util.find-ns 2 | (:require [com.billpiel.sayid.util.other :as util])) 3 | 4 | (defn unnest-symbol 5 | [s] 6 | (cond 7 | (symbol? s) s 8 | 9 | (when (list? s) 10 | (-> s first (= 'quote))) 11 | (recur (second s)) 12 | 13 | :else nil)) 14 | 15 | (defn alias->ns 16 | [s ref-ns] 17 | (some-> ref-ns 18 | ns-aliases 19 | (get s) 20 | str 21 | symbol)) 22 | 23 | (defn re-find-nses 24 | [q] 25 | (when-let [re (util/$- some->> q 26 | name 27 | (re-find #"(.*?)\*$") 28 | second 29 | java.util.regex.Pattern/quote 30 | (str $ ".*") 31 | re-pattern)] 32 | (->> (all-ns) 33 | (filter #(->> % 34 | str 35 | (re-find re))) 36 | not-empty))) 37 | 38 | (defn search-nses 39 | [q ref-ns] 40 | (let [q' (unnest-symbol q)] 41 | (-> (or (re-find-nses q') 42 | (alias->ns q' ref-ns) 43 | q') 44 | vector 45 | flatten))) 46 | -------------------------------------------------------------------------------- /test/com/billpiel/sayid/test_ns1.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.test-ns1 2 | (:require [com.billpiel.sayid.util.other :refer [$-]])) 3 | 4 | (defn func2 5 | [arg1] 6 | arg1) 7 | 8 | (defn func1 9 | [arg1] 10 | (func2 arg1)) 11 | 12 | (defn func-throws 13 | [arg1] 14 | (throw (Exception. (str "Exception from func-throws: " arg1)))) 15 | 16 | (defn func3-4 17 | [arg1] 18 | arg1) 19 | 20 | (defn func3-2 21 | [arg1] 22 | (* 2 arg1)) 23 | 24 | (defn func3-2 25 | [arg1] 26 | (+ 3 arg1)) 27 | 28 | (defn func3-3 29 | [arg1] 30 | (func3-2 (inc arg1)) 31 | (func3-4 arg1)) 32 | 33 | (defn func3-1 34 | [arg1 arg2] 35 | (func3-2 arg1) 36 | (func3-3 arg2) 37 | (+ 2 38 | (func3-2 arg2))) 39 | 40 | (defn print-sleep 41 | [n] 42 | (println "Sleeping " n) 43 | (Thread/sleep n)) 44 | 45 | (defn func-sleep-30 [] 46 | (Thread/sleep 30)) 47 | 48 | (defn func-sleep-20 [] 49 | (Thread/sleep 20) 50 | (func-sleep-30) 51 | (func-sleep-30)) 52 | 53 | (defn func-sleep-10 [] 54 | (Thread/sleep 10) 55 | (func-sleep-20) 56 | (func-sleep-30) 57 | (func-sleep-20)) 58 | 59 | (defn func-identity 60 | [& args] 61 | args) 62 | 63 | (defn func-complex 64 | [a b] 65 | (let [c (* a b)] 66 | (-> c 67 | inc 68 | (+ a) 69 | vector 70 | (into [11 22]) 71 | (conj b)))) 72 | 73 | (defn func-666 74 | [a b] 75 | (vector a (+ a (* 2 b)))) 76 | 77 | 78 | (defn func-loop 79 | [a] 80 | (loop [b a] 81 | (inc b) 82 | (+ b a))) 83 | 84 | -------------------------------------------------------------------------------- /test/com/billpiel/sayid/recording_test.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.recording-test 2 | (:require [clojure.test :as t] 3 | [com.billpiel.sayid.recording :as r] 4 | [com.billpiel.sayid.workspace :as w] 5 | [com.billpiel.sayid.test-utils :as t-utils])) 6 | 7 | (t/deftest recording 8 | (with-redefs [gensym (t-utils/mock-gensym-fn)] 9 | (let [shelf '$rec 10 | rec (atom (r/mk-recording [])) 11 | ws (w/default-workspace)] 12 | 13 | (t/testing "save-as" 14 | (t/is (= @(r/save-as! rec shelf 'test1) 15 | {:children [] 16 | :depth 0 17 | :id :rec10 18 | :path [:rec10] 19 | :rec-slot '$rec/test1}))) 20 | 21 | (reset! rec {}) 22 | 23 | (t/testing "load - not forced, fails" 24 | (t/is (thrown? Exception 25 | (r/load! rec shelf 'test1)))) 26 | 27 | (t/testing "load - forced" 28 | (t/is (= (r/load! rec shelf 'test1 :f) 29 | {:children [] 30 | :depth 0 31 | :id :rec10 32 | :path [:rec10] 33 | :rec-slot '$rec/test1}))) 34 | 35 | (t/testing "coerce & load" 36 | (r/coerce&load! rec ws shelf) 37 | (t/is (= @rec 38 | {:children [] 39 | :depth 0 40 | :id :rec12 41 | :path [:rec12] 42 | :rec-slot nil}))) 43 | 44 | (remove-ns shelf)))) 45 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/shelf.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.shelf 2 | (:require [com.billpiel.sayid.util.other :as util])) 3 | 4 | 5 | (defn save! 6 | [item shelf slot-kw mk-ex-msg-fn] 7 | (let [item' @item 8 | slot (slot-kw item')] 9 | (if (symbol? slot) 10 | (util/def-ns-var shelf slot item') 11 | (throw (Exception. (mk-ex-msg-fn 12 | slot)))) 13 | item')) 14 | 15 | (defn save-as! 16 | [item shelf slot-kw slot mk-ex-msg-fn] 17 | (doto item 18 | (swap! assoc slot-kw 19 | (util/qualify-sym shelf slot)) 20 | (save! shelf slot-kw mk-ex-msg-fn))) 21 | 22 | (defn safe-to-load? 23 | [item shelf slot-kw & [force]] 24 | (let [item' @item] 25 | (or (= :f force) 26 | (nil? item') 27 | (some->> item' 28 | slot-kw 29 | (ns-resolve shelf))))) 30 | 31 | (defn load! 32 | [item shelf slot-kw slot-src load-over-unsaved-ex-msg & [force]] 33 | (if (safe-to-load? item 34 | shelf 35 | slot-kw 36 | force) 37 | (let [source (util/just-get-whatever-you-can shelf 38 | slot-src)] 39 | (reset! item source)) 40 | (throw (Exception. load-over-unsaved-ex-msg)))) 41 | 42 | #_ (defn load! 43 | [item shelf slot load-over-unsaved-ex-msg & [force]] 44 | (if (safe-to-load? item shelf force) 45 | (reset! item @(ns-resolve shelf slot)) 46 | (throw (Exception. load-over-unsaved-ex-msg)))) 47 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/sayid_multifn.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.sayid-multifn 2 | (:gen-class :name com.billpiel.sayid.SayidMultiFn 3 | :init init 4 | :constructors {[clojure.lang.IPersistentMap] 5 | [String 6 | clojure.lang.IFn 7 | Object 8 | clojure.lang.IRef]} 9 | :extends clojure.lang.MultiFn 10 | :prefix "-" 11 | :state state)) 12 | 13 | (defn -init 14 | [m] 15 | (let [original (:original m)] 16 | [["SAYID-MULTIFN" 17 | (.-dispatchFn original) 18 | (.-defaultDispatchVal original) 19 | (.-hierarchy original)] 20 | m])) 21 | 22 | (defn -invoke 23 | [this & args] 24 | (let [{:keys [original trace-dispatch-fn trace-method-fn]} (.state this) 25 | dispatch-fn (.-dispatchFn original) 26 | dispatch-val (trace-dispatch-fn dispatch-fn 27 | args) 28 | method (.getMethod original dispatch-val)] 29 | (trace-method-fn method 30 | args))) 31 | 32 | (defn -reset 33 | [this] 34 | (-> this .state :original .reset)) 35 | 36 | (defn -addMethod 37 | [this dispatch-val method] 38 | (.addMethod (:original (.state this)) 39 | dispatch-val 40 | method)) 41 | 42 | (defn -removeMethod 43 | [this dispatch-val] 44 | (-> this .state :original (.removeMethod dispatch-val))) 45 | 46 | (defn -preferMethod 47 | [this dispatch-val-x dispatch-val-y] 48 | (-> this .state :original (.preferMethod dispatch-val-x dispatch-val-y))) 49 | 50 | (defn -getMethodTable 51 | [this] 52 | (some-> this .state :original .getMethodTable)) 53 | 54 | (defn -getPreferTable 55 | [this] 56 | (-> this .state :original .getPreferTable)) 57 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject com.billpiel/sayid "0.1.0" 2 | :description "Sayid is a library for debugging and profiling clojure code." 3 | :url "https://github.com/clojure-emacs/sayid" 4 | :scm {:name "git" :url "https://github.com/clojure-emacs/sayid"} 5 | :license {:name "Apache License, Version 2.0" 6 | :url "http://www.apache.org/licenses/LICENSE-2.0"} 7 | 8 | :dependencies [[tamarin "0.1.2"] 9 | [org.clojure/tools.reader "1.3.2"] 10 | [org.clojure/tools.namespace "1.0.0"]] 11 | :exclusions [org.clojure/clojure] ; see versions matrix below 12 | 13 | :aot [com.billpiel.sayid.sayid-multifn] 14 | 15 | :deploy-repositories [["clojars" {:url "https://clojars.org/repo" 16 | :username :env/clojars_username 17 | :password :env/clojars_password 18 | :sign-releases false}]] 19 | 20 | :repl-options {:nrepl-middleware [com.billpiel.sayid.nrepl-middleware/wrap-sayid]} 21 | 22 | :profiles {;; Clojure versions matrix 23 | :provided {:dependencies [[org.clojure/clojure "1.10.1"] 24 | [org.clojure/clojure "1.10.1" :classifier "sources"]]} 25 | :1.8 {:dependencies [[org.clojure/clojure "1.8.0"] 26 | [org.clojure/clojure "1.8.0" :classifier "sources"]]} 27 | :1.9 {:dependencies [[org.clojure/clojure "1.9.0"] 28 | [org.clojure/clojure "1.9.0" :classifier "sources"]]} 29 | :1.10 {:dependencies [[org.clojure/clojure "1.10.1"] 30 | [org.clojure/clojure "1.10.1" :classifier "sources"]]} 31 | 32 | :dev {:dependencies [[nrepl "0.7.0"]]}} 33 | 34 | :aliases {"test-all" ["with-profile" "+1.8:+1.9:+1.10" "test"]}) 35 | -------------------------------------------------------------------------------- /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((emacs-lisp-mode 5 | (bug-reference-url-format . "https://github.com/clojure-emacs/sayid/issues/%s") 6 | (bug-reference-bug-regexp . "#\\(?2:[[:digit:]]+\\)") 7 | (indent-tabs-mode . nil) 8 | (fill-column . 80) 9 | (sentence-end-double-space . t) 10 | (emacs-lisp-docstring-fill-column . 75) 11 | (checkdoc-symbol-words . ("top-level" "major-mode" "macroexpand-all" "print-level" "print-length")) 12 | (checkdoc-package-keywords-flag) 13 | (checkdoc-arguments-in-order-flag) 14 | (checkdoc-verb-check-experimental-flag) 15 | (elisp-lint-indent-specs . ((if-let* . 2) 16 | (when-let* . 1) 17 | (let* . defun) 18 | (nrepl-dbind-response . 2) 19 | (cider-save-marker . 1) 20 | (cider-propertize-region . 1) 21 | (cider-map-repls . 1) 22 | (cider--jack-in . 1) 23 | (cider--make-result-overlay . 1) 24 | ;; need better solution for indenting cl-flet bindings 25 | (multiline-comment-handler . defun) ;; cl-flet 26 | (insert-label . defun) ;; cl-flet 27 | (insert-align-label . defun) ;; cl-flet 28 | (insert-rect . defun) ;; cl-flet 29 | (cl-defun . 2) 30 | (with-parsed-tramp-file-name . 2) 31 | (thread-first . 1) 32 | (thread-last . 1)))) 33 | (clojure-mode 34 | (clojure-indent-style . :always-align) 35 | (indent-tabs-mode . nil) 36 | (fill-column . 80))) 37 | 38 | ;; To use the bug-reference stuff, do: 39 | ;; (add-hook 'text-mode-hook #'bug-reference-mode) 40 | ;; (add-hook 'prog-mode-hook #'bug-reference-prog-mode) 41 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | 3 | ## unreleased 4 | 5 | * [#61](https://github.com/clojure-emacs/sayid/issues/61): Remove version extraction logic. 6 | * Decouple the injected `sayid` plugin version from the version of the Emacs client (see `sayid-injected-plugin-version`). 7 | * `sayid-trace-ns-by-pattern` accepts interactive argument. 8 | 9 | ## [0.1.0] - 2020-09-02 10 | 11 | * [#57](https://github.com/clojure-emacs/sayid/issues/57): Fix version extraction logic. 12 | 13 | ## [0.0.19] - 2020-08-20 14 | 15 | ### Fixed 16 | 17 | * Fix nREPL middleware and Lein plugin version numbers. 18 | 19 | ## [0.0.18] - 2019-08-26 20 | 21 | ### Changed 22 | 23 | * Removed support for nREPL 0.2.x. 24 | * Removed hard dep on Clojure. 25 | 26 | ## [0.0.17] - 2018-09-01 27 | 28 | ### Added 29 | 30 | * Added support for nREPL 0.4. 31 | 32 | ## [0.0.16] - 2018-04-04 33 | 34 | ### Added 35 | 36 | * Auto inject depencencies at cider-jack-in time. Thanks, Benedek Fazekas! 37 | 38 | ### Fixed 39 | 40 | * upgrade to org.clojure/tools.reader "1.3.0-alpha3" 41 | 42 | ## [0.0.15] - 2017-05-02 43 | 44 | ### Fixed 45 | 46 | * emacs: disable undo to avoid buffer limit error 47 | * emacs: fix background colors in pretty-print buffer 48 | * support inner-tracing of `loop` form with multi-form body 49 | 50 | ## [0.0.14] - 2017-03-06 51 | 52 | ### Changed 53 | 54 | * emacs: several misc things for MELPA 55 | 56 | ## [0.0.13] - 2017-02-22 57 | 58 | ### Fixed 59 | 60 | * emacs: messed up some function names 61 | 62 | ## [0.0.12] - 2017-02-21 63 | 64 | ### Changed 65 | 66 | * emacs: improve render speed 67 | * emacs: prepare package for submission to melpa 68 | * emacs: useful message when sayid not responding 69 | 70 | ### Fixed 71 | 72 | * support sets in pretty-print buffer 73 | 74 | ## [0.0.11] - 2017-01-10 75 | 76 | ### Added 77 | 78 | * CHANGELOG.md 79 | 80 | ### Changed 81 | 82 | * Improved inner tracing 83 | * ex. `recur` no longer triggers explosion 84 | * Improved multimethod tracing 85 | * traced multimethod is still a MultiFn 86 | * dispatcher return value captured 87 | * Emacs : keybinding `q` to quit window 88 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/test1.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | *cider-repl localhost* 6 | 59 | 60 | 61 | 
62 |  ; CIDER 0.9.1 (Java 1.7.0_91, Clojure 1.8.0, nREPL 0.2.9)
63 |  user> (puget.printer/cprint [1 2 :3])
64 |  [1 2 :3]
65 |  nil
66 |  user>
67 | 68 | 69 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/view.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.view 2 | (:require [com.billpiel.sayid.util.other :as util])) 3 | 4 | 5 | ;; ================================================================== 6 | ;; These also exist in query. Move to some common location. 7 | 8 | 9 | (defn get-some* 10 | [f v] 11 | (cond 12 | (fn? f) 13 | (f v) 14 | 15 | (set? f) 16 | (f v) 17 | 18 | :default 19 | (get v f))) 20 | 21 | (defn get-some 22 | [coll v] 23 | (loop [coll coll 24 | v v] 25 | (if ((some-fn empty? nil?) coll) 26 | v 27 | (let [[f & r] coll] 28 | (when-let [v' (get-some* f v)] 29 | (recur r v')))))) 30 | 31 | (defn wrap-wildcards 32 | [re] 33 | (re-pattern (str ".*" re ".*"))) 34 | 35 | (defn eq* [pred v] 36 | (cond (fn? pred) 37 | (pred v) 38 | 39 | (set? pred) 40 | (pred v) 41 | 42 | (instance? java.util.regex.Pattern pred) 43 | (->> v 44 | str 45 | (re-matches (wrap-wildcards pred))) 46 | 47 | (= pred (boolean pred)) ;; added this 48 | pred 49 | 50 | :default (= pred v))) 51 | 52 | (defn mk-query-fn 53 | [query-coll] 54 | (let [path (drop-last query-coll) 55 | pred (last query-coll)] 56 | (fn [v] 57 | (try 58 | (->> v 59 | (get-some path) 60 | (eq* pred)) 61 | (catch Exception ex 62 | nil))))) 63 | 64 | (defn some-mk-query-fn 65 | [queries] 66 | (->> queries 67 | (map mk-query-fn) 68 | (apply some-fn))) 69 | 70 | ;; ================================================================== 71 | 72 | (defn pred-sel-pairs->view 73 | [pairs] 74 | (let [pairs' (map (fn [[pred sel]] 75 | [(-> pred 76 | util/->vec 77 | mk-query-fn) 78 | sel]) 79 | pairs)] 80 | (->> pairs' 81 | (map first) 82 | (apply some-fn)))) 83 | 84 | (defn pred-sel-pair->pred-fn 85 | [[pred sel]] 86 | (fn [tree] 87 | (if ((-> pred 88 | util/->vec 89 | mk-query-fn) 90 | tree) 91 | (if (fn? sel) 92 | (sel tree) 93 | sel) 94 | nil))) 95 | 96 | (defn pred-sel-pairs->view 97 | [pairs] 98 | (->> pairs 99 | (map pred-sel-pair->pred-fn) 100 | (apply some-fn))) 101 | 102 | (defn mk-simple-view 103 | ([] (mk-simple-view {:args true 104 | :return true 105 | :throw true 106 | :selects false})) 107 | ([selector] (pred-sel-pairs->view [[true selector]]))) 108 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/recording.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.recording 2 | (:require [com.billpiel.sayid.workspace :as ws] 3 | [com.billpiel.sayid.trace :as trace] 4 | [com.billpiel.sayid.util.other :as util] 5 | [com.billpiel.sayid.shelf :as shelf])) 6 | 7 | (def bad-slot-msg "Recording must have a symbol value in :rec-slot. Value was `%s`. Try `save-as!` instead.") 8 | (def unknown-type-msg "Unknown type. `rec` must be a recording, workspace or trace tree. Received a %s.") 9 | (def load-over-unsaved "Current recording is not saved. Use :f as last arg to force, or else `save!` first.") 10 | 11 | (defn reset-to-nil! 12 | [rec] 13 | (reset! rec nil)) 14 | 15 | (defn mk-recording 16 | [children] 17 | (-> (trace/mk-tree :id-prefix "rec") 18 | (merge {:rec-slot nil 19 | :children children}) 20 | (vary-meta assoc 21 | ::recording 22 | true) 23 | (vary-meta assoc 24 | ::trace-root 25 | true))) 26 | 27 | (defn ->recording 28 | [v] 29 | (let [mv (meta v)] 30 | (cond 31 | (::recording mv) 32 | v 33 | 34 | (::ws/workspace mv) 35 | (-> v ws/deep-deref! :children mk-recording) 36 | 37 | (::trace/tree mv) 38 | (mk-recording [v]) 39 | 40 | :default 41 | (throw (ex-info (format unknown-type-msg 42 | (type v)) 43 | {::success false 44 | ::code :unknown-type}))))) 45 | 46 | (defn save! 47 | [rec shelf] 48 | (shelf/save! rec 49 | shelf 50 | :rec-slot 51 | #(format bad-slot-msg %))) 52 | 53 | ;; rec could be: 54 | ;; recording 55 | ;; workspace 56 | ;; tree 57 | (defn save-as! 58 | [rec shelf slot] 59 | (shelf/save-as! rec 60 | shelf 61 | :rec-slot 62 | slot 63 | #(format bad-slot-msg %))) 64 | 65 | (defn load! 66 | [rec shelf slot & [force]] 67 | (shelf/load! rec 68 | shelf 69 | :rec-slot 70 | slot 71 | load-over-unsaved 72 | force)) 73 | 74 | (defn coerce&load! 75 | [rec source shelf & [force]] 76 | (shelf/load! rec 77 | shelf 78 | :rec-slot 79 | (try (-> source 80 | util/atom?-> 81 | ->recording) 82 | (catch Exception ex 83 | (if (-> ex ex-data ::code (= :unknown-type)) 84 | (throw (Exception. (.getMessage ex))) ;; uh... prob get rid of this 85 | (throw ex)))) 86 | load-over-unsaved 87 | force)) 88 | -------------------------------------------------------------------------------- /test/com/billpiel/sayid/test_utils.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.test-utils) 2 | 3 | ;; https://github.com/Prismatic/plumbing/blob/6f9f1b6453ed2c978a619dc99bb0317d8c053141/src/plumbing/core.cljx#L356 4 | (defn swap-pair! 5 | "Like swap! but returns a pair [old-val new-val]" 6 | ([a f] 7 | (loop [] 8 | (let [old-val @a 9 | new-val (f old-val)] 10 | (if (compare-and-set! a old-val new-val) 11 | [old-val new-val] 12 | (recur))))) 13 | ([a f & args] 14 | (swap-pair! a #(apply f % args)))) 15 | 16 | (defn make-mock-series-fn 17 | [f s] 18 | (let [a (atom s)] 19 | (fn [& args] 20 | (let [v (-> a 21 | (swap-pair! subvec 1) 22 | first 23 | first)] 24 | (apply f (into [v] args)))))) 25 | 26 | (let [[f & r] (range 1 100)] [f r]) 27 | 28 | 29 | (defn make-mock-series-lazy-fn 30 | [f s] 31 | (let [a (atom s)] 32 | (fn [& args] 33 | (let [v (-> a 34 | (swap-pair! rest) 35 | first 36 | first)] 37 | (apply f (into [v] args)))))) 38 | 39 | (def mock-now-fn #(make-mock-series-fn identity 40 | (vec (range 0 1000)))) 41 | 42 | (def mock-gensym-fn (fn [] 43 | (make-mock-series-fn 44 | (fn [id & [pre]] 45 | (str (or pre "") id)) 46 | (vec (map str (range 10 1000)))))) 47 | 48 | (defn remove-iso-ctrl [s] (apply str (remove #(Character/isISOControl %) s))) 49 | 50 | (def ansi-colors [:black :red :green :yellow :blue :magenta :cyan :white]) 51 | 52 | (defn kw->bg [kw] (->> kw name (str "bg-") keyword)) 53 | 54 | (defn ansi->kw 55 | [a] 56 | (try (let [a' (if (string? a) 57 | (Integer/parseInt a) 58 | a)] 59 | (cond (= a' 0) :bold-off 60 | (= a' 1) :bold 61 | (<= 30 a' 39) (nth ansi-colors (mod a' 10)) 62 | (<= 40 a' 49) (->> (mod a' 10) 63 | (nth ansi-colors) 64 | kw->bg))) 65 | (catch Exception ex nil))) 66 | 67 | (defn replace-ansi* 68 | [s coll] 69 | (if-let [[both text code] (re-find (re-pattern (format "(?is)^(.*?)(%s\\[[\\d;]*m)" \u001B)) 70 | s)] 71 | (do [s both (count both) text (count text) code (count code)] 72 | (recur (subs s (count both)) 73 | (into coll [text code]))) 74 | (into coll [s]))) 75 | 76 | (defn tag-ansi 77 | [s] 78 | (if-let [[_ code] (re-find (re-pattern (format "%s\\[([\\d;]*)m" \u001B)) 79 | s)] 80 | (let [codes (clojure.string/split code #";")] 81 | (mapv ansi->kw codes)) 82 | s)) 83 | 84 | (defn replace-ansi 85 | [s] 86 | (let [v (replace-ansi* s [])] 87 | (mapv tag-ansi v))) 88 | 89 | (defn redact-file-fn 90 | [& paths] 91 | (fn [v] 92 | (loop [v v 93 | [f & r] paths] 94 | (if (nil? f) 95 | v 96 | (recur (update-in v f (constantly "FILE")) 97 | r))))) 98 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/profiling.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.profiling 2 | (:require [com.billpiel.sayid.trace :as tr] 3 | [com.billpiel.sayid.recording :as rec] 4 | [com.billpiel.sayid.util.other :as util] 5 | [clojure.walk :as w])) 6 | 7 | (defn merge-profile-values 8 | [a b] 9 | ((cond (number? a) + 10 | (set? a) clojure.set/union 11 | :default (throw (Exception. (format "Cant' merge this: '%s'" a)))) 12 | a b)) 13 | 14 | (def merge-profiles 15 | (memoize 16 | (fn [& rest] 17 | (apply merge-with 18 | #(merge-with merge-profile-values % %2) 19 | rest)))) 20 | 21 | (defn finalize-profiles 22 | [fn-ms] 23 | (util/apply-to-map-vals (fn [metrics] 24 | (let [arg-cardinality (-> metrics :arg-set count) 25 | call-count (:count metrics) 26 | gross-time-sum (or (:gross-time-sum metrics) 0) 27 | repeat-arg-pct (- 1 (/ arg-cardinality 28 | call-count 29 | 1.0))] 30 | (-> metrics 31 | (dissoc :arg-set) 32 | (assoc :gross-time-avg (/ gross-time-sum 33 | call-count 34 | 1.0) 35 | :net-time-avg (/ (or (:net-time-sum metrics) 0) 36 | call-count 37 | 1.0) 38 | :arg-cardinality arg-cardinality 39 | :repeat-arg-pct repeat-arg-pct 40 | :gross-of-repeats (* gross-time-sum 41 | repeat-arg-pct))))) 42 | fn-ms)) 43 | 44 | (defn get-profile 45 | [tree] 46 | (let [{{:keys [gross-time net-time arg-set]} :profiling 47 | name :name 48 | children :children} tree 49 | entry {(keyword name) 50 | {:count 1 51 | :gross-time-sum gross-time 52 | :net-time-sum net-time 53 | :arg-set arg-set}}] 54 | (if children 55 | (apply merge-profiles 56 | entry 57 | (map get-profile 58 | children)) 59 | entry))) 60 | 61 | (defn hash-safe 62 | [x] 63 | (hash (w/prewalk (fn [v] 64 | (if (seq? v) 65 | (take 10000 v) 66 | v)) 67 | x))) 68 | 69 | (defn mk-arg-hash-set 70 | [tree] 71 | (->> tree 72 | :args 73 | (map hash-safe) 74 | set)) 75 | 76 | 77 | (defn add-durations-to-tree 78 | [tree] 79 | (let [gross-time (->> tree 80 | ((juxt :ended-at :started-at)) 81 | (apply -)) 82 | children (->> tree 83 | :children 84 | (mapv add-durations-to-tree)) 85 | kids-time (->> children 86 | (map (comp :gross-time :profiling)) 87 | (apply +)) 88 | net-time (- gross-time kids-time)] 89 | (assoc tree 90 | :children children 91 | :profiling {:gross-time gross-time 92 | :net-time net-time 93 | :kids-time kids-time 94 | :arg-set (mk-arg-hash-set tree)}))) 95 | 96 | (defn assoc-tree-with-profile 97 | [tree] 98 | (let [tree' (->> tree 99 | :children 100 | (mapv add-durations-to-tree) 101 | rec/mk-recording)] 102 | (->> tree' 103 | :children 104 | (map get-profile) 105 | (apply merge-profiles) 106 | finalize-profiles 107 | (assoc tree' :profile)))) 108 | 109 | (defn get-report 110 | [tree]) 111 | 112 | (defn print-report 113 | [tree]) 114 | -------------------------------------------------------------------------------- /test/com/billpiel/sayid/workspace_test.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.workspace-test 2 | (:require [clojure.test :as t] 3 | [com.billpiel.sayid.workspace :as ws] 4 | [com.billpiel.sayid.test-utils :as t-utils])) 5 | 6 | (def ^:dynamic *shelf*) 7 | (def ^:dynamic *ws*) 8 | 9 | (defn fixture 10 | [f] 11 | (with-redefs [gensym (t-utils/mock-gensym-fn)] 12 | (binding [*shelf* '$ws 13 | *ws* (atom (ws/default-workspace))] 14 | (f) 15 | (remove-ns *shelf*)))) 16 | 17 | (t/use-fixtures :each fixture) 18 | 19 | (t/deftest save-as 20 | (t/testing "ws save-as" 21 | (t/is (= (ws/deep-deref! (ws/save-as! *ws* 22 | *shelf* 23 | 'test1)) 24 | {:children [] 25 | :depth 0 26 | :id :root10 27 | :path [:root10] 28 | :traced {:ns #{}, :fn #{}, :inner-fn #{}} 29 | :ws-slot '$ws/test1 30 | :arg-map nil}))) 31 | 32 | (ws/reset-to-nil! *ws*) 33 | 34 | (t/testing "saved successful?" 35 | (t/is (= (ws/deep-deref! @(ns-resolve (the-ns *shelf*) 36 | 'test1)) 37 | {:children [] 38 | :depth 0 39 | :id :root10 40 | :path [:root10] 41 | :traced {:ns #{}, :fn #{}, :inner-fn #{}} 42 | :ws-slot '$ws/test1 43 | :arg-map nil})))) 44 | 45 | (t/deftest load-with-symbol 46 | (t/testing "load with symbol" 47 | (ws/save-as! *ws* *shelf* 'test1) 48 | (ws/reset-to-nil! *ws*) 49 | 50 | (ws/load! *ws* *shelf* 'test1) 51 | 52 | (t/is (= (ws/deep-deref! *ws*) 53 | {:children [] 54 | :depth 0 55 | :id :root10 56 | :path [:root10] 57 | :traced {:ns #{}, :fn #{}, :inner-fn #{}} 58 | :ws-slot '$ws/test1 59 | :arg-map nil})))) 60 | 61 | (t/deftest load-with-value 62 | (t/testing "load with value" 63 | (ws/save-as! *ws* *shelf* 'test1) 64 | (ws/reset-to-nil! *ws*) 65 | 66 | (t/testing "; start with nil" 67 | (t/is (= (ws/deep-deref! *ws*) 68 | nil))) 69 | 70 | (t/testing "; loading" 71 | (ws/load! *ws* *shelf* @(ns-resolve '$ws 'test1)) 72 | (t/is (= (ws/deep-deref! *ws*) 73 | {:children [] 74 | :depth 0 75 | :id :root10 76 | :path [:root10] 77 | :traced {:ns #{}, :fn #{}, :inner-fn #{}} 78 | :ws-slot '$ws/test1 79 | :arg-map nil}))))) 80 | 81 | (t/deftest load-with-keyword 82 | (t/testing "load with keyword" 83 | (ws/save-as! *ws* *shelf* 'test1) 84 | (ws/reset-to-nil! *ws*) 85 | 86 | (t/testing "; start with nil" 87 | (t/is (= (ws/deep-deref! *ws*) 88 | nil))) 89 | 90 | (t/testing "; loading" 91 | (ws/load! *ws* *shelf* :test1) 92 | 93 | (t/is (= (ws/deep-deref! *ws*) 94 | {:children [] 95 | :depth 0 96 | :id :root10 97 | :path [:root10] 98 | :traced {:ns #{}, :fn #{}, :inner-fn #{}} 99 | :ws-slot '$ws/test1 100 | :arg-map nil}))))) 101 | 102 | (t/deftest forced-load 103 | (t/testing "forced load" 104 | (ws/save-as! *ws* *shelf* 'test1) 105 | (ws/reset-to-nil! *ws*) 106 | (ws/init! *ws*) 107 | 108 | 109 | (t/is (thrown? Exception 110 | (ws/load! *ws* *shelf* 'test1))) 111 | 112 | (t/testing "; didn't overwrite" 113 | (t/is (= (ws/deep-deref! *ws*) 114 | {:children [] 115 | :depth 0 116 | :id :root11 117 | :path [:root11] 118 | :traced {:ns #{}, :fn #{}, :inner-fn #{}} 119 | :ws-slot nil 120 | :arg-map nil}))) 121 | 122 | (t/testing "; loading" 123 | (ws/load! *ws* *shelf* 'test1 :f) 124 | 125 | (t/is (= (ws/deep-deref! *ws*) 126 | {:children [] 127 | :depth 0 128 | :id :root10 129 | :path [:root10] 130 | :traced {:ns #{}, :fn #{}, :inner-fn #{}} 131 | :ws-slot '$ws/test1 132 | :arg-map nil}))))) 133 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/workspace.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.workspace 2 | (:require [com.billpiel.sayid.trace :as trace] 3 | [com.billpiel.sayid.util.other :as util] 4 | [com.billpiel.sayid.shelf :as shelf])) 5 | 6 | (def default-traced {:ns #{} 7 | :fn #{} 8 | :inner-fn #{}}) 9 | 10 | (defn default-workspace 11 | [] 12 | (-> (trace/mk-tree :id-prefix "root") 13 | (merge {:traced default-traced 14 | :ws-slot nil}) 15 | (vary-meta assoc 16 | ::workspace 17 | true) 18 | (vary-meta assoc 19 | :trace-root 20 | true))) 21 | 22 | (defn workspace->tree 23 | [ws] 24 | (-> ws 25 | (dissoc :traced 26 | :ws-slot) 27 | (vary-meta dissoc ::workspace))) 28 | 29 | (defn lookup-traces-by-fn 30 | [ws fn-sym] 31 | (let [[ns-sym] (util/disqualify-sym fn-sym)] 32 | (->> ws 33 | :traced 34 | (filter #(some (or (-> % second) 35 | (constantly nil)) 36 | [fn-sym ns-sym])) 37 | (mapv first)))) 38 | 39 | (defn init! 40 | [ws & [quiet]] 41 | (when-not (or (compare-and-set! ws nil (default-workspace)) 42 | (#{:quiet} quiet)) 43 | (throw 44 | (Exception. 45 | "Cannot run `ws-init!` if workspace is not `nil`. Run `ws-reset!` first or pass :quiet as second arg."))) 46 | ws) 47 | 48 | (defn reset-to-nil! 49 | [ws] 50 | (reset! ws nil)) 51 | 52 | (defn new-log! 53 | [ws] 54 | (swap! ws assoc :children (atom []))) 55 | 56 | (defn clear-log! 57 | [ws] 58 | (reset! (:children @ws) 59 | [])) 60 | 61 | (defn remove-trace-*! 62 | "Untrace all fns in the given name space." 63 | [ws type sym] 64 | (swap! ws update-in 65 | [:traced type] 66 | disj sym) 67 | (trace/untrace* type sym)) 68 | 69 | (defn add-trace-*! 70 | [ws type sym] 71 | (when-let [existing-trace-type (and (#{:fn :inner-fn} type) 72 | (-> sym 73 | trace/check-fn-trace-type 74 | #{:fn :inner-fn}))] 75 | (remove-trace-*! ws 76 | existing-trace-type 77 | sym)) 78 | (swap! ws (fn [ws'] (-> ws' 79 | (update-in [:traced type] 80 | conj sym)))) 81 | (trace/trace* type sym @ws)) 82 | 83 | (defn enable-all-traces! 84 | ([ws] 85 | (enable-all-traces! ws identity)) 86 | ([ws filter-fn] 87 | (let [w @ws 88 | f (fn [type] (doseq [sym (util/$- -> w 89 | (get-in [:traced type]) 90 | (filter filter-fn $))] 91 | (trace/trace* type sym w)))] 92 | (doall (map f [:inner-fn 93 | :fn 94 | :ns])) 95 | true))) 96 | 97 | (defn enable-trace-fn! 98 | [ws fn-sym] 99 | (let [w @ws] 100 | (when-let [traces (->> fn-sym 101 | (lookup-traces-by-fn w) 102 | (replace {:ns :fn}))] 103 | (doseq [t traces] 104 | (trace/trace* t fn-sym w)))) 105 | true) 106 | 107 | (defn disable-all-traces! 108 | ([ws] (disable-all-traces! ws identity)) 109 | ([ws filter-fn] 110 | (doseq [t (->> @ws 111 | :traced 112 | util/flatten-map-kv-pairs 113 | (filter (comp filter-fn second)))] 114 | (apply trace/untrace* t)))) 115 | 116 | (defn disable-trace-fn! 117 | [ws fn-sym] 118 | (when-let [traces (->> fn-sym 119 | (lookup-traces-by-fn @ws) 120 | (replace {:ns :fn}))] 121 | (doseq [t traces] 122 | (trace/untrace* t fn-sym))) 123 | true) 124 | 125 | (defn remove-all-traces! 126 | [ws] 127 | (disable-all-traces! ws) 128 | (swap! ws assoc :traced default-traced)) 129 | 130 | (defn remove-trace-fn! 131 | [ws fn-sym] 132 | (when-let [trace-type (trace/check-fn-trace-type fn-sym)] 133 | (println trace-type) 134 | (remove-trace-*! ws 135 | trace-type 136 | fn-sym)) 137 | (doseq [t (->> fn-sym 138 | (lookup-traces-by-fn @ws) 139 | (filter #{:fn :inner-fn}))] ;; func may have been disabled or out of sync 140 | 141 | (remove-trace-*! ws 142 | t 143 | fn-sym))) 144 | 145 | (defn deep-deref! 146 | [tree] 147 | (if-let [tree' (util/atom?-> tree)] 148 | (let [dr-kids (-> tree' :children util/atom?->) 149 | forced-arg-map (-> tree' :arg-map force) 150 | kids (mapv deep-deref! dr-kids)] 151 | (assoc tree' 152 | :children kids 153 | :arg-map forced-arg-map)))) 154 | 155 | (defn save! 156 | [ws ws-shelf] 157 | (shelf/save! ws 158 | ws-shelf 159 | :ws-slot 160 | #(format "Workspace must have a symbol value in :ws-slot. Value was `%s`. Try `save-as!` instead." %))) 161 | 162 | (defn save-as! 163 | [ws ws-shelf slot] 164 | (shelf/save-as! ws 165 | ws-shelf 166 | :ws-slot 167 | slot 168 | #(format "Workspace must have a symbol value in :ws-slot. Value was `%s`. Try `save-as!` instead." %))) 169 | 170 | ;; TODO remove traces before unloading a ws??? 171 | (defn load! 172 | [ws ws-shelf slot & [force]] 173 | (shelf/load! ws 174 | ws-shelf 175 | :ws-slot 176 | slot 177 | "Current workspace is not saved. Use :f as last arg to force, or else `save!` first." 178 | force)) 179 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/util/tree_query.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.util.tree-query 2 | (:require [clojure.zip :as z] 3 | [swiss.arrows :refer [-<> -<>>]])) 4 | 5 | (def ^:dynamic *get-tags-mz* nil) 6 | 7 | (defn iter-while-identity 8 | [f v] 9 | (->> v 10 | (iterate f) 11 | (take-while identity))) 12 | 13 | (defn right-sib-zips 14 | [z] 15 | (->> z 16 | (iter-while-identity z/right) 17 | rest)) 18 | 19 | (defn left-sib-zips 20 | [z] 21 | (->> z 22 | (iter-while-identity z/left) 23 | rest)) 24 | 25 | (defn all-sib-zips [z] 26 | (->> z 27 | z/leftmost 28 | right-sib-zips 29 | (filter #(not (= % z))))) 30 | 31 | (defn parent-zips 32 | [z] 33 | (->> z 34 | (iter-while-identity z/up) 35 | rest)) 36 | 37 | (defn children-zips [z] 38 | (->> z 39 | z/down 40 | (iter-while-identity z/right))) 41 | 42 | (defn set-zip-children 43 | [z c] 44 | (z/edit z #(z/make-node z 45 | % 46 | c))) 47 | 48 | (defn get-tags 49 | [node pred-map] 50 | (vec (for [[kw pred] pred-map 51 | :when (pred node)] 52 | kw))) 53 | 54 | (defn get-tags' 55 | [node pred-map] 56 | ((or *get-tags-mz* get-tags) 57 | node 58 | pred-map)) 59 | 60 | (defn conj* 61 | [& r] 62 | (if (= (count r) 1) 63 | (first r) 64 | (apply conj r))) 65 | 66 | (defn insert-tags-into-summary 67 | [& [tags summary]] 68 | {:path (if tags 69 | (-<> summary 70 | :path 71 | (or []) 72 | (into [tags] 73 | <>)) 74 | []) 75 | :set (if tags 76 | (-<> summary 77 | :set 78 | (or #{}) 79 | (apply conj* <> tags)) 80 | #{})}) 81 | 82 | (defn merge-children-tag-summary 83 | [& rest] 84 | {:paths (->> rest 85 | (mapcat :paths) 86 | vec) 87 | :set (->> rest 88 | (map :set) 89 | (apply clojure.set/union))}) 90 | 91 | (defn insert-tag-into-children-tag-summary 92 | [tag ch-tags] 93 | {:paths (-<> ch-tags 94 | :paths 95 | not-empty 96 | (or [[]]) 97 | (mapv #(into [tag] %) 98 | <>)) 99 | :set (-<> ch-tags 100 | :set 101 | (or #{}) 102 | (apply conj* <> tag))}) 103 | 104 | (def get-children-tag-summary* 105 | (memoize 106 | (fn [zipr pred-map] 107 | (let [this-tags (-> zipr 108 | z/node 109 | (get-tags' pred-map))] 110 | (insert-tag-into-children-tag-summary this-tags 111 | (if-let [ch-zips (-> zipr 112 | children-zips 113 | not-empty)] 114 | (->> ch-zips 115 | (map #(get-children-tag-summary* % 116 | pred-map)) 117 | (apply merge-children-tag-summary)) 118 | (merge-children-tag-summary))))))) 119 | 120 | (defn get-children-tag-summary ;; memoize? 121 | [zipr pred-map] 122 | (->> zipr 123 | children-zips 124 | (map #(get-children-tag-summary* % 125 | pred-map)) 126 | (apply merge-children-tag-summary))) 127 | 128 | #_ (ppcp (get-children-tag-summary z1 129 | {:a #(-> % :id #{1 2 3 4}) :even #(-> (do %) 130 | :id 131 | even?)})) 132 | (def seq->tag-summary 133 | (memoize 134 | (fn [zips pred-map] 135 | (let [[fst & rest] (or zips [])] 136 | (insert-tags-into-summary 137 | (when fst 138 | (get-tags' (z/node fst) 139 | pred-map)) 140 | (when rest 141 | (seq->tag-summary rest 142 | pred-map))))))) 143 | 144 | (defn tag* 145 | [zipr pred-map] 146 | (let [get-tag-summary #(-> zipr 147 | % 148 | (seq->tag-summary pred-map))] 149 | (z/edit zipr (fn [z] (with-meta z 150 | {::? {:tags (get-tags' (z/node zipr) pred-map) 151 | :parents (get-tag-summary parent-zips) ; (get-parents-tag-summary zipr pred-map) 152 | :children (get-children-tag-summary zipr 153 | pred-map) 154 | :old-sibs (get-tag-summary left-sib-zips) 155 | :young-sibs (get-tag-summary right-sib-zips)}}))))) 156 | 157 | (defn tag 158 | [zipr pred-map] 159 | (binding [*get-tags-mz* (memoize get-tags)] 160 | (loop [z (-> zipr 161 | (tag* pred-map))] 162 | (let [zn (z/next z)] 163 | (if-not (z/end? zn) 164 | (recur (tag* zn pred-map)) 165 | ;; reset zipper 166 | (z/edit zipr (-> z z/root constantly))))))) 167 | 168 | (defn pred-query 169 | [zipr pred] 170 | (let [z' (set-zip-children zipr 171 | (->> zipr 172 | children-zips 173 | (mapcat #(pred-query % 174 | pred)) 175 | vec)) 176 | n (z/node z')] 177 | (if (-> n 178 | meta 179 | ::? 180 | pred) 181 | [n] ;; clear meta ::? 182 | (z/children z')))) 183 | 184 | (defn query 185 | [zipr pred-map pred-final] 186 | (-> zipr 187 | (tag pred-map) 188 | (pred-query pred-final))) 189 | 190 | (defn has-all-tags-fn 191 | [& tags] 192 | (fn [node] 193 | (clojure.set/subset? (set tags) 194 | (-> node :tags set)))) 195 | 196 | (defn has-any-tags-fn 197 | [& tags] 198 | (fn [node] 199 | (some (set tags) 200 | (:tags node)))) 201 | 202 | 203 | (defn has-child-fn []) 204 | 205 | (defn has-descen-fn 206 | [& tags] 207 | (fn [node] 208 | (some (set tags) 209 | (-> node 210 | :children 211 | :set)))) 212 | 213 | (defn has-parent-fn []) 214 | 215 | (defn has-ancest-fn [& tags] 216 | (fn [node] 217 | (some (set tags) 218 | (-> node 219 | :parents 220 | :set)))) 221 | 222 | (defn has-closer-ancest-fn []) 223 | (defn has-closer-descen-fn []) 224 | 225 | (defn is-between-fn [ancestor descendant] 226 | (every-pred (has-ancest-fn ancestor) 227 | (has-descen-fn descendant))) 228 | 229 | (defn is-strict-between-fn []) 230 | 231 | #_ (do 232 | (def z2 (tag z1 233 | {:a #(-> % :id #{1 2 3 4}) :even #(-<> (do %) 234 | :id 235 | even?)})) 236 | 237 | (ppcp tree2) 238 | (println) 239 | (-> tree2 240 | meta 241 | ppcp)) 242 | 243 | #_ (do 244 | 245 | (def tree {:id 1 :children 246 | [{:id 2} 247 | {:id 3 248 | :children [{:id 5 249 | :children [{:id 6}]}]} 250 | {:id 4 251 | :children [{:id 7 252 | :children []} 253 | {:id 8 254 | :children []} 255 | ]}]}) 256 | 257 | [[[:a :even]] 258 | [[:a] [] [:even]] 259 | [[:a :even] []] 260 | [[:a :even] [:even]]] 261 | 262 | 263 | 264 | (def ppcp puget.printer/cprint) 265 | 266 | (ppcp tree) 267 | 268 | (def z1 (z/zipper map? 269 | #(-> % :children not-empty) 270 | #(assoc % :children %2) 271 | tree)) 272 | 273 | (def qr1 (query z1 {:a #(-> % :id #{6})} 274 | #(->> % :children :set (some #{:a})) 275 | )) 276 | 277 | (ppcp (z/root z1)) 278 | 279 | 280 | 281 | (comment)) 282 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/trace.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.trace 2 | (:require [com.billpiel.sayid.util.other :as util]) 3 | (:import com.billpiel.sayid.SayidMultiFn)) 4 | 5 | (def ^:dynamic *trace-log-parent* nil) 6 | 7 | (defn now [] (System/currentTimeMillis)) 8 | 9 | (defn mk-tree 10 | [& {:keys [id-prefix parent]}] 11 | (let [id (-> id-prefix 12 | gensym 13 | keyword) 14 | path (conj (or (:path parent) 15 | []) 16 | id)] 17 | ^::tree {:id id 18 | :path path 19 | :depth (or (some-> parent :depth inc) 0) 20 | :children (atom [])})) 21 | 22 | (defn mk-fn-tree 23 | [& {:keys [parent name args meta]}] 24 | (assoc (mk-tree :parent parent) ;; 3 sec 25 | :name name 26 | :args (vec args) 27 | :meta meta 28 | :arg-map (delay (util/arg-match-safe (-> meta 29 | :arglists 30 | vec) 31 | args)) 32 | :started-at (now))) 33 | 34 | (defn StackTraceElement->map 35 | [^StackTraceElement o] 36 | {:class-name (.getClassName o) 37 | :file-name (.getFileName o) 38 | :method-name (.getMethodName o) 39 | :line-number (.getLineNumber o)}) 40 | 41 | (defn Throwable->map** 42 | "Constructs a data representation for a Throwable." 43 | {:added "1.7"} 44 | [^Throwable o] 45 | (let [base (fn [^Throwable t] 46 | (let [m {:type (class t) 47 | :message (.getLocalizedMessage t) 48 | :at (StackTraceElement->map (get (.getStackTrace t) 0))} 49 | data (ex-data t)] 50 | (if data 51 | (assoc m :data data) 52 | m))) 53 | via (loop [via [], ^Throwable t o] 54 | (if t 55 | (recur (conj via t) (.getCause t)) 56 | via)) 57 | ^Throwable root (peek via) 58 | m {:cause (.getLocalizedMessage root) 59 | :via (vec (map base via)) 60 | :trace (mapv StackTraceElement->map (.getStackTrace ^Throwable (or root o)))} 61 | data (ex-data root)] 62 | (if data 63 | (assoc m :data data) 64 | m))) 65 | 66 | 67 | (defn start-trace 68 | [trace-log tree] 69 | (swap! trace-log 70 | conj 71 | tree)) ;; string!! 72 | 73 | (defn end-trace 74 | [trace-log idx tree] 75 | (swap! trace-log 76 | update-in 77 | [idx] 78 | #(merge % tree))) 79 | 80 | (defn trace-fn-call 81 | [workspace name f args meta'] 82 | (let [parent (or *trace-log-parent* 83 | workspace) 84 | this (mk-fn-tree :parent parent ;; mk-fn-tree = 200ms 85 | :name name 86 | :args args 87 | :meta meta') 88 | idx (-> (start-trace (:children parent) ;; start-trace = 20ms 89 | this) 90 | count 91 | dec)] 92 | (let [value (binding [*trace-log-parent* this] ;; binding = 50ms 93 | (try 94 | (apply f args) 95 | (catch Throwable t 96 | (end-trace (:children parent) 97 | idx 98 | {:throw (Throwable->map** t) 99 | :ended-at (now)}) 100 | (throw t))))] 101 | (end-trace (:children parent) ;; end-trace = 75ms 102 | idx 103 | {:return value 104 | :ended-at (now)}) 105 | value))) 106 | 107 | (defn shallow-tracer-multifn 108 | [{:keys [workspace qual-sym meta']} original-fn] 109 | (com.billpiel.sayid.SayidMultiFn. {:original original-fn 110 | :trace-dispatch-fn (fn [f args] 111 | (trace-fn-call workspace 112 | (symbol (str qual-sym "--DISPATCHER")) 113 | f 114 | args 115 | meta')) 116 | :trace-method-fn (fn [f args] 117 | (trace-fn-call workspace 118 | qual-sym 119 | f 120 | args 121 | meta'))})) 122 | 123 | (defn ^{::trace-type :fn} shallow-tracer 124 | [{:keys [workspace qual-sym meta'] :as m} original-fn] 125 | (if (= (type original-fn) clojure.lang.MultiFn) 126 | (shallow-tracer-multifn m original-fn) 127 | (fn tracing-wrapper [& args] 128 | (trace-fn-call workspace 129 | qual-sym 130 | original-fn 131 | args 132 | meta')))) 133 | 134 | (defn apply-trace-to-var 135 | [^clojure.lang.Var v tracer-fn workspace] 136 | (let [ns (.ns v) 137 | s (.sym v) 138 | m (meta v) 139 | f @v 140 | vname (util/qualify-sym ns s )] 141 | (doto v 142 | (alter-var-root (partial tracer-fn 143 | {:workspace workspace 144 | :ns' ns 145 | :sym s 146 | :qual-sym vname 147 | :meta' m})) 148 | (alter-meta! assoc ::traced [(:id workspace) f]) 149 | (alter-meta! assoc ::trace-type (-> tracer-fn meta ::trace-type))))) 150 | 151 | (defn untrace-var* 152 | ([ns s] 153 | (untrace-var* (ns-resolve ns s))) 154 | ([v] 155 | (let [^clojure.lang.Var v (if (var? v) v (resolve v)) 156 | ns (.ns v) 157 | s (.sym v) 158 | [_ f] ((meta v) ::traced)] 159 | (when f 160 | (doto v 161 | (alter-var-root (constantly f)) 162 | (alter-meta! dissoc 163 | ::traced 164 | ::trace-type)))))) 165 | 166 | (defn trace-var* 167 | [v tracer-fn workspace & {:keys [no-overwrite]}] 168 | (let [^clojure.lang.Var v (if (var? v) v (resolve v))] 169 | (when (and (ifn? @v) (-> v meta :macro not)) 170 | (if-let [[traced-id traced-f] (-> v meta ::traced)] 171 | (when (and (not no-overwrite) 172 | (or (not= traced-id (:id workspace)) 173 | (not= (-> tracer-fn meta ::trace-type) 174 | (-> v meta ::trace-type)))) 175 | (untrace-var* v) 176 | (apply-trace-to-var v tracer-fn workspace)) 177 | (apply-trace-to-var v tracer-fn workspace))))) 178 | 179 | (defn the-ns-safe 180 | [ns] 181 | (try (the-ns ns) 182 | (catch Exception e 183 | nil))) 184 | 185 | (defn trace-ns* 186 | [ns workspace] 187 | (when-let [ns (the-ns-safe ns)] 188 | (when-not ('#{clojure.core com.billpiel.sayid.core} (.name ns)) 189 | (let [ns-fns (->> ns ns-interns vals (filter (comp util/fn*? var-get)))] 190 | (doseq [f ns-fns] 191 | (trace-var* f 192 | (util/assoc-var-meta-to-fn shallow-tracer 193 | ::trace-type) 194 | workspace 195 | :no-overwrite true)))))) 196 | 197 | (defn untrace-ns* 198 | [ns*] 199 | (when-let [ns' (the-ns-safe ns*)] 200 | (let [ns-fns (->> ns' ns-interns vals)] 201 | (doseq [f ns-fns] 202 | (untrace-var* f))))) 203 | 204 | (defn apply->vec 205 | [f] 206 | (fn [v] [v (f v)])) 207 | 208 | (defn audit-fn 209 | [fn-var trace-selection] 210 | (let [fn-meta (meta fn-var)] 211 | (-> fn-meta 212 | (update-in [:ns] str) 213 | (assoc :trace-type (::trace-type fn-meta) 214 | :trace-selection trace-selection) 215 | (dissoc ::trace-type 216 | ::traced)))) 217 | 218 | (defn audit-fn-sym 219 | [fn-sym trace-selection] 220 | (-> fn-sym 221 | resolve 222 | (audit-fn trace-selection))) 223 | 224 | (defn audit-ns 225 | [ns-sym] 226 | (try (let [mk-vec-fn (fn [fn-var] 227 | [(-> fn-var meta :name) 228 | (audit-fn fn-var :ns)])] 229 | (->> ns-sym 230 | ns-interns 231 | vals 232 | (filter (comp fn? var-get)) 233 | (map mk-vec-fn) 234 | (into (sorted-map)))) 235 | (catch Exception ex 236 | (sorted-map)))) 237 | 238 | (defn audit-traces 239 | [traced] 240 | (let [{outer :fn inner :inner-fn ns' :ns} traced 241 | f (fn [trace-type] 242 | (fn [fn-sym] 243 | (let [fn-var (resolve fn-sym)] 244 | [(-> fn-var meta :name) 245 | (audit-fn fn-var trace-type)]))) 246 | fn-audits (->> (concat (map (f :fn) outer) 247 | (map (f :inner-fn) inner)) 248 | (group-by #(-> % second :ns)) 249 | (map (fn [[k v]] [(symbol k) (into (sorted-map) v)])) 250 | (into (sorted-map)))] 251 | {:ns (into (sorted-map) 252 | (map (apply->vec audit-ns) 253 | ns')) 254 | :fn fn-audits})) 255 | 256 | (defn check-fn-trace-type 257 | [fn-sym] 258 | (-> fn-sym 259 | resolve 260 | meta 261 | ::trace-type)) 262 | 263 | (defmulti trace* (fn [type sym workspace] type)) 264 | 265 | (defmethod trace* :ns 266 | [_ sym workspace] 267 | (trace-ns* sym workspace)) 268 | 269 | 270 | 271 | (defmethod trace* :fn 272 | [_ fn-sym workspace] 273 | (-> fn-sym 274 | resolve 275 | (trace-var* (util/assoc-var-meta-to-fn shallow-tracer 276 | ::trace-type) 277 | workspace))) 278 | 279 | (defmulti untrace* (fn [type sym] type)) 280 | 281 | (defmethod untrace* :ns 282 | [_ sym] 283 | (untrace-ns* sym)) 284 | 285 | (defmethod untrace* :fn 286 | [_ fn-sym] 287 | (-> fn-sym 288 | resolve 289 | untrace-var*)) 290 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/util/other.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.util.other 2 | (:require [clojure.walk :as walk] 3 | [clojure.tools.reader :as r] 4 | [clojure.tools.reader.reader-types :as rts] 5 | clojure.repl)) 6 | 7 | (defn ->int 8 | [v] 9 | (try (cond (integer? v) v 10 | (string? v) (Integer/parseInt v) 11 | (float? v) (int v)) 12 | (catch Exception e 13 | nil))) 14 | 15 | (defn ->vec 16 | [v] 17 | (cond (vector? v) v 18 | (sequential? v) (vec v) 19 | (coll? v) (vec v) 20 | :else [v])) 21 | 22 | (defn ->symbol 23 | [v] 24 | (cond (= (type v) clojure.lang.Namespace) (symbol (.getName v)) 25 | (keyword? v) (-> v name symbol) 26 | (string? v) (symbol v) 27 | :else (-> v str symbol))) 28 | 29 | (defn def-ns-var 30 | [ws-ns-sym sym v] 31 | (binding [*ns* (create-ns ws-ns-sym)] 32 | (eval `(def ~sym '~v)))) 33 | 34 | (defn eval-in-ns 35 | [ns-sym form] 36 | (binding [*ns* (create-ns ns-sym)] 37 | (use 'clojure.core) 38 | (eval form))) 39 | 40 | (defn macroexpand-in-ns 41 | [ns-sym form] 42 | (eval-in-ns ns-sym `(macroexpand '~form))) 43 | 44 | (defn macroexpand-all-in-ns 45 | [ns-sym form] 46 | (eval-in-ns ns-sym `(walk/macroexpand-all '~form))) 47 | 48 | (defn macro? 49 | [ns-sym m-sym] 50 | (try (some->> m-sym 51 | (ns-resolve ns-sym) 52 | meta 53 | :macro) 54 | (catch Exception e false))) 55 | 56 | (defmacro get-env 57 | [] 58 | (into {} (for [k (keys &env)] 59 | [`'~k k]))) 60 | 61 | (defn apply-to-map-vals 62 | [f m] 63 | (into {} (map (fn [[k v]] [k (f v)]) 64 | m))) 65 | 66 | (defn clear-meta 67 | [v] 68 | (with-meta v nil)) 69 | 70 | (defn cleanse-arglist 71 | "Clear out pre-condtions and tags." 72 | [arglist] 73 | (->> arglist 74 | clear-meta 75 | (mapv clear-meta))) 76 | 77 | (defn arg-matcher-fn 78 | [arglists] 79 | (when (not-empty arglists) 80 | (let [arities (map #(list % '(com.billpiel.sayid.util.other/get-env)) ;; NOTE! NS/get-env must match this ns 81 | arglists) 82 | fn1 `(fn ~@arities)] 83 | (eval fn1)))) 84 | 85 | (def arg-matcher-fn-memo (memoize arg-matcher-fn)) 86 | 87 | (defn arg-match 88 | [arglists args] 89 | (def arglists' arglists) 90 | (def args' args) 91 | (if (not-empty arglists) 92 | (let [args-v (vec args) 93 | matcher-fn (->> arglists 94 | (map cleanse-arglist) 95 | arg-matcher-fn-memo)] 96 | (apply matcher-fn args-v)) 97 | (zipmap (range) args))) 98 | 99 | (defn arg-match-safe 100 | [arglists args] 101 | (try 102 | (arg-match arglists args) 103 | (catch Exception e 104 | nil))) 105 | 106 | (defn qualify-sym 107 | [ns sym] 108 | (symbol (str ns) 109 | (str sym))) 110 | 111 | (defn disqualify-sym 112 | [fn-sym] 113 | (->> fn-sym 114 | str 115 | (re-find #"(.*?)/(.*)") 116 | rest 117 | (mapv symbol))) 118 | 119 | (defmacro fully-qualify-sym 120 | [sym] 121 | `(let [m# (-> ~sym 122 | resolve 123 | meta) 124 | ns# (-> m# :ns str) 125 | name# (-> m# :name)] 126 | (qualify-sym ns# name#))) 127 | 128 | (defn resolve-to-qual-sym [ns-sym sym] 129 | (try (when-let [{:keys [name ns]} (meta (ns-resolve ns-sym sym))] 130 | (qualify-sym ns name)) 131 | (catch Exception e 132 | nil))) 133 | 134 | (defn atom? 135 | [v] 136 | (instance? clojure.lang.Atom v)) 137 | 138 | (defn atom?-> 139 | [maybe-atom] 140 | (if (atom? maybe-atom) 141 | @maybe-atom 142 | maybe-atom)) 143 | 144 | (defn atom?-fn 145 | [maybe-atom] 146 | (if (atom? maybe-atom) 147 | [@maybe-atom 148 | (fn [newval] 149 | (reset! maybe-atom newval) 150 | maybe-atom) 151 | (fn [f] 152 | (swap! maybe-atom f) 153 | maybe-atom)] 154 | [maybe-atom identity identity])) 155 | 156 | 157 | (defn derefable? 158 | [v] 159 | (instance? clojure.lang.IDeref v)) 160 | 161 | (defn derefable?-> 162 | [maybe-ideref] 163 | (if (derefable? maybe-ideref) 164 | @maybe-ideref 165 | maybe-ideref)) 166 | 167 | (defn obj-pred-action-else 168 | [obj pred & {:keys [t t-fn f f-fn]}] 169 | (let [pred' (or pred identity)] 170 | (if (pred' obj) 171 | (let [fn' (if t-fn 172 | t-fn 173 | (constantly (if (nil? t) 174 | obj 175 | t)))] 176 | (fn' obj)) 177 | (let [fn' (cond 178 | f-fn f-fn 179 | (and t (not f)) (constantly obj) 180 | (and t-fn (not f)) (constantly obj) 181 | :else (constantly f))] 182 | (fn' obj))))) 183 | 184 | (def opae obj-pred-action-else) 185 | 186 | (defn just-get-whatever-you-can 187 | [ns-sym clue] 188 | (-> clue 189 | (obj-pred-action-else keyword? :t-fn name) 190 | (obj-pred-action-else string? :t-fn symbol) 191 | (obj-pred-action-else symbol? :t-fn #(ns-resolve ns-sym %)) 192 | derefable?->)) 193 | 194 | (defn replace$ 195 | [form] 196 | (let [$sym `$# 197 | form' (walk/prewalk-replace {'$ $sym} 198 | form)] 199 | (if (= form form') 200 | form 201 | `((fn [~$sym] ~form'))))) 202 | 203 | (defmacro $- 204 | [m & body] 205 | `(~m ~@(map replace$ body))) 206 | 207 | (defmacro defalias 208 | [alias source] 209 | `(do (def ~alias ~source) 210 | (alter-meta! #'~alias merge 211 | (-> #'~source 212 | meta 213 | (select-keys [:arglists 214 | :doc]) 215 | (update-in [:doc] #(format "An alias for `%s`.\n%s" 216 | (name '~source) 217 | %)))))) 218 | 219 | (defn defalias-macro* 220 | [alias source] 221 | (let [body-sym (gensym "body") 222 | qualified-source (qualify-sym *ns* source) 223 | source-meta (->> source 224 | (ns-resolve *ns*) 225 | meta) 226 | arglists (:arglists source-meta) 227 | split-at-& (fn [arg-vec] 228 | (let [[pre amp post] 229 | (partition-by #{'&} arg-vec)] 230 | (if (-> arg-vec 231 | first 232 | #{'&}) 233 | (concat amp) 234 | (concat [(vec pre)] post)))) 235 | forms (map (fn [args] 236 | `(~args 237 | (clojure.core/seq 238 | (clojure.core/concat 239 | (clojure.core/list '~qualified-source) 240 | ~@(split-at-& args))))) 241 | arglists)] 242 | `(do (defmacro ~alias ~@forms) 243 | (alter-meta! #'~alias merge 244 | (-> (var ~qualified-source) 245 | meta 246 | (select-keys [:arglists 247 | :doc]) 248 | (update-in [:doc] #(format "An alias for `%s`.\n%s" 249 | (name '~source) 250 | %)))) 251 | #'~alias))) 252 | 253 | (defmacro defalias-macro 254 | [alias source] 255 | (defalias-macro* alias source)) 256 | 257 | (defn ns-unmap-all 258 | [ns'] 259 | (->> ns' 260 | ns-map 261 | keys 262 | (map (partial ns-unmap ns')) 263 | dorun)) 264 | 265 | (defn source-fn-var 266 | [fn-var] 267 | (->> fn-var 268 | meta 269 | ((juxt :ns 270 | (constantly "/") 271 | :name)) 272 | (apply str) 273 | symbol 274 | clojure.repl/source-fn)) 275 | 276 | (defn mk-dummy-whitespace 277 | [lines cols] 278 | (apply str 279 | (concat (repeat lines "\n") 280 | (repeat cols " ")))) 281 | 282 | (defn mk-positionalble-src-logging-push-back-rdr 283 | [s file line col] 284 | (rts/source-logging-push-back-reader (str (mk-dummy-whitespace (dec line) ;;this seem unfortunate 285 | (dec col)) 286 | s) 287 | (+ (count s) line col 1) 288 | file)) 289 | 290 | (defn hunt-down-source 291 | [fn-sym] 292 | (let [{:keys [source file line column]} (-> fn-sym 293 | resolve 294 | meta)] 295 | (or source 296 | (r/read (mk-positionalble-src-logging-push-back-rdr 297 | (or 298 | (clojure.repl/source-fn fn-sym) 299 | (->> file 300 | slurp 301 | clojure.string/split-lines 302 | (drop (dec line)) 303 | (clojure.string/join "\n")) 304 | "nil") 305 | file 306 | line 307 | column))))) 308 | 309 | (defmacro src-in-meta 310 | [& body] 311 | `(alter-meta! ~body assoc :source '~body)) 312 | 313 | (defn back-into 314 | "Puts the contents of `noob` into a collection of the same type as `orig`." 315 | [orig noob] 316 | ((if (seq? orig) 317 | reverse 318 | identity) 319 | (into (or (empty orig) 320 | []) 321 | noob))) 322 | 323 | (defn deep-zipmap-no-colls 324 | [a b] 325 | (zipmap (filter (comp not coll?) (tree-seq coll? seq a)) 326 | (filter (comp not coll?) (tree-seq coll? seq b)))) 327 | 328 | 329 | (defn deep-zipmap 330 | [a b] 331 | (zipmap (tree-seq coll? seq a) 332 | (tree-seq coll? seq b))) 333 | 334 | (defn flatten-map-kv-pairs 335 | [m] 336 | (mapcat (fn [[k v]] 337 | (mapv vector 338 | (repeat k) 339 | v)) 340 | m)) 341 | 342 | (defmacro assoc-var-meta-to-fn 343 | [fn-sym meta-key] 344 | `(vary-meta ~fn-sym 345 | assoc 346 | ~meta-key 347 | (-> #'~fn-sym 348 | meta 349 | ~meta-key))) 350 | 351 | 352 | (defn get-some* 353 | [f v] 354 | (cond 355 | (fn? f) 356 | (f v) 357 | 358 | (set? f) 359 | (f v) 360 | 361 | :default 362 | (get v f))) 363 | 364 | (defn get-some 365 | [coll v] 366 | (loop [coll coll 367 | v v] 368 | (if ((some-fn empty? nil?) coll) 369 | v 370 | (let [[f & r] coll] 371 | (when-let [v' (get-some* f v)] 372 | (recur r v')))))) 373 | 374 | 375 | (defn quote-if-sym 376 | [v] 377 | (if (symbol? v) 378 | `'~v 379 | v)) 380 | 381 | (defn first-match 382 | [pred coll] 383 | (let [[head & tail] coll] 384 | (cond (nil? coll) nil 385 | (empty? coll) nil 386 | (pred head) head 387 | :else (recur pred tail)))) 388 | 389 | (defn get-src-file-path 390 | [s] 391 | (let [s' (clojure.string/replace s #"^file:" "")] 392 | (if (.exists (java.io.File. s')) 393 | s' 394 | (when-let [r (clojure.java.io/resource s')] 395 | (.getPath r))))) 396 | 397 | (defn fn*? 398 | [maybe] 399 | (or (fn? maybe) 400 | (= (type maybe) clojure.lang.MultiFn))) 401 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /test/com/billpiel/sayid/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.core-test 2 | (:require [clojure.test :as t] 3 | [com.billpiel.sayid.core :as sd] 4 | [com.billpiel.sayid.trace :as sdt] 5 | [com.billpiel.sayid.query2 :as sdq] 6 | [com.billpiel.sayid.test-utils :as t-utils] 7 | [com.billpiel.sayid.test-ns1 :as ns1] 8 | [com.billpiel.sayid.string-output2 :as sds])) 9 | 10 | 11 | (defn- fixture 12 | [f] 13 | (sdt/untrace-ns* 'com.billpiel.sayid.test-ns1) 14 | (with-out-str (sd/ws-reset!)) 15 | (with-redefs [sdt/now (t-utils/mock-now-fn) 16 | gensym (t-utils/mock-gensym-fn)] 17 | (f) 18 | (sdt/untrace-ns* 'com.billpiel.sayid.test-ns1))) 19 | 20 | (t/use-fixtures :each fixture) 21 | 22 | (t/deftest version-test 23 | (t/is (string? sd/version))) 24 | 25 | (t/deftest add-remove-trace-ns 26 | 27 | (t/testing "ws-add-trace-ns!" 28 | (sd/ws-add-trace-ns! ns1) 29 | (ns1/func1 :a) 30 | (let [trace (sd/ws-deref!) 31 | expected-trace {:arg-map nil, 32 | :children 33 | [{:args [:a], 34 | :path [:root10 :11], 35 | :children 36 | [{:args [:a], 37 | :path [:root10 :11 :12], 38 | :children [], 39 | :meta 40 | {:arglists '([arg1]), 41 | :column 1, 42 | :file "FILE", 43 | :line 4, 44 | :name 'func2, 45 | :ns (the-ns 'com.billpiel.sayid.test-ns1)}, 46 | :return :a, 47 | :started-at 1 48 | :name 'com.billpiel.sayid.test-ns1/func2, 49 | :arg-map {'arg1 :a}, 50 | :id :12, 51 | :ended-at 2 52 | :depth 2}], 53 | :meta 54 | {:arglists '([arg1]), 55 | :column 1, 56 | :file "FILE", 57 | :line 8, 58 | :name 'func1, 59 | :ns (the-ns 'com.billpiel.sayid.test-ns1)}, 60 | :return :a, 61 | :started-at 0 62 | :name 'com.billpiel.sayid.test-ns1/func1, 63 | :arg-map {'arg1 :a}, 64 | :id :11, 65 | :ended-at 3 66 | :depth 1}], 67 | :depth 0, 68 | :id :root10, 69 | :path [:root10], 70 | :traced 71 | {:inner-fn #{}, :fn #{}, :ns #{'com.billpiel.sayid.test-ns1}}, 72 | :ws-slot nil}] 73 | (t/is (= (-> trace 74 | ((t-utils/redact-file-fn [:children 0 :meta :file] 75 | [:children 0 :children 0 :meta :file]))) 76 | expected-trace)) 77 | 78 | (t/testing "ws-remove-trace-ns!" 79 | (sd/ws-remove-trace-ns! 'ns1) 80 | (ns1/func1 :b) 81 | (t/is (= (-> (sd/ws-deref!) 82 | ((t-utils/redact-file-fn [:children 0 :meta :file] 83 | [:children 0 :children 0 :meta :file]))) 84 | (assoc expected-trace 85 | :traced {:fn #{}, :ns #{}, :inner-fn #{}}))))))) 86 | 87 | 88 | (t/deftest ed-all-traces 89 | 90 | (sd/ws-add-trace-ns! com.billpiel.sayid.test-ns1) 91 | 92 | (t/testing "ws-disable-all-traces!" 93 | (sd/ws-disable-all-traces!) 94 | (com.billpiel.sayid.test-ns1/func1 :a) 95 | (t/is (= (sd/ws-deref!) 96 | {:children [] 97 | :depth 0 98 | :id :root10 99 | :path [:root10] 100 | :traced {:inner-fn #{}, :fn #{}, :ns #{'com.billpiel.sayid.test-ns1}} 101 | :ws-slot nil 102 | :arg-map nil}))) 103 | 104 | (t/testing "ws-enable-all-traces!" 105 | (sd/ws-enable-all-traces!) 106 | (com.billpiel.sayid.test-ns1/func1 :a) 107 | 108 | (t/is (= (-> (sd/ws-deref!) 109 | ((t-utils/redact-file-fn [:children 0 :meta :file] 110 | [:children 0 :children 0 :meta :file]))) 111 | {:arg-map nil 112 | :children [{:arg-map {'arg1 :a} 113 | :args [:a] 114 | :children [{:arg-map {'arg1 :a} 115 | :args [:a] 116 | :children [] 117 | :depth 2 118 | :ended-at 2 119 | :id :12 120 | :meta {:arglists '([arg1]) 121 | :column 1 122 | :file "FILE" 123 | :line 4 124 | :name 'func2 125 | :ns (the-ns 'com.billpiel.sayid.test-ns1)} 126 | :name 'com.billpiel.sayid.test-ns1/func2 127 | :path [:root10 :11 :12] 128 | :return :a 129 | :started-at 1}] 130 | :depth 1 131 | :ended-at 3 132 | :id :11 133 | :meta {:arglists '([arg1]) 134 | :column 1 135 | :file "FILE" 136 | :line 8 137 | :name 'func1 138 | :ns (the-ns 'com.billpiel.sayid.test-ns1)} 139 | :name 'com.billpiel.sayid.test-ns1/func1 140 | :path [:root10 :11] 141 | :return :a 142 | :started-at 0}] 143 | :depth 0 144 | :id :root10 145 | :path [:root10] 146 | :traced {:inner-fn #{} 147 | :fn #{} 148 | :ns #{'com.billpiel.sayid.test-ns1}} 149 | :ws-slot nil})))) 150 | 151 | (t/deftest remove-all-traces 152 | (sd/ws-add-trace-ns! ns1) 153 | 154 | (t/testing "remove-all-traces! works" 155 | (with-out-str (sd/ws-remove-all-traces!)) 156 | (ns1/func1 :a) 157 | 158 | (t/is (= (sd/ws-deref!) 159 | {:children [] 160 | :depth 0 161 | :id :root10 162 | :path [:root10] 163 | :traced {:fn #{} :ns #{} :inner-fn #{}} 164 | :ws-slot nil 165 | :arg-map nil})))) 166 | 167 | (t/deftest exception-thrown 168 | (t/testing "exception thrown" 169 | (let [trace-root (sd/ws-add-trace-ns! com.billpiel.sayid.test-ns1) 170 | _ (try 171 | (com.billpiel.sayid.test-ns1/func-throws :a) 172 | (catch Throwable t)) 173 | trace (sd/ws-deref!)] 174 | 175 | (t/testing "; trace root" 176 | (t/is (= (dissoc trace :children) 177 | {:depth 0 178 | :id :root10 179 | :path [:root10] 180 | :traced {:fn #{}, :ns #{'com.billpiel.sayid.test-ns1}, :inner-fn #{}} 181 | :ws-slot nil 182 | :arg-map nil}))) 183 | 184 | (t/testing "; children count" 185 | (t/is (= (-> trace :children count) 186 | 1))) 187 | 188 | (t/testing "; throw cause" 189 | (t/is (= (-> trace :children first :throw :cause) 190 | "Exception from func-throws: :a"))) 191 | 192 | (t/testing "; first child" 193 | (t/is (= (-> trace 194 | :children 195 | first 196 | (dissoc :throw) 197 | ((t-utils/redact-file-fn [:meta :file]))) 198 | {:args [:a] 199 | :children [] 200 | :depth 1 201 | :ended-at 1 202 | :id :11 203 | :name 'com.billpiel.sayid.test-ns1/func-throws 204 | :path [:root10 :11] 205 | :started-at 0 206 | :meta {:arglists '([arg1]) 207 | :column 1 208 | :file "FILE" 209 | :line 12 210 | :name 'func-throws 211 | :ns (the-ns 'com.billpiel.sayid.test-ns1)} 212 | :arg-map {'arg1 :a}})))))) 213 | 214 | (t/deftest querying 215 | (t/testing "q macro" 216 | (let [trace-root (sd/ws-add-trace-ns! com.billpiel.sayid.test-ns1) 217 | _ (com.billpiel.sayid.test-ns1/func3-1 3 8) 218 | trace (sd/ws-deref!)] 219 | 220 | (t/testing "; find node by name and all parents" 221 | (t/is (= 222 | (->> (sd/w-q :a [:name #".*func3-4"]) 223 | sdq/traverse-tree-dissoc-zipper 224 | ((t-utils/redact-file-fn [:children 0 :meta :file] 225 | [:children 0 :children 0 :meta :file] 226 | [:children 0 :children 0 :children 0 :meta :file]))) 227 | {:arg-map nil 228 | :children [{:arg-map {'arg1 3 229 | 'arg2 8} 230 | :args [3 8] 231 | :children [{:arg-map {'arg1 8} 232 | :args [8] 233 | :children [{:arg-map {'arg1 8} 234 | :args [8] 235 | :children [] 236 | :depth 3 237 | :ended-at 7 238 | :id :15 239 | :meta {:arglists '([arg1]) 240 | :column 1 241 | :file "FILE" 242 | :line 16 243 | :name 'func3-4 244 | :ns (the-ns 'com.billpiel.sayid.test-ns1)} 245 | :name 'com.billpiel.sayid.test-ns1/func3-4 246 | :path [:root10 :11 :13 :15] 247 | :return 8 248 | :started-at 6}] 249 | :depth 2 250 | :ended-at 8 251 | :id :13 252 | :meta {:arglists '([arg1]) 253 | :column 1 254 | :file "FILE" 255 | :line 28 256 | :name 'func3-3 257 | :ns (the-ns 'com.billpiel.sayid.test-ns1)} 258 | :name 'com.billpiel.sayid.test-ns1/func3-3 259 | :path [:root10 :11 :13] 260 | :return 8 261 | :started-at 3}] 262 | :depth 1 263 | :ended-at 11 264 | :id :11 265 | :meta {:arglists '([arg1 arg2]) 266 | :column 1 267 | :file "FILE" 268 | :line 33 269 | :name 'func3-1 270 | :ns (the-ns 'com.billpiel.sayid.test-ns1)} 271 | :name 'com.billpiel.sayid.test-ns1/func3-1 272 | :path [:root10 :11] 273 | :return 13 274 | :started-at 0}] 275 | :depth 0 276 | :id :root10 277 | :path [:root10] 278 | :traced {:inner-fn #{} 279 | :fn #{} 280 | :ns #{'com.billpiel.sayid.test-ns1}} 281 | :ws-slot nil})))))) 282 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/query2.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.query2 2 | (:require [clojure.zip :as z] 3 | [com.billpiel.sayid.util.other :as util])) 4 | 5 | ;; === zipper iterators 6 | 7 | (defn iter-while-identity 8 | [f v] 9 | (->> v 10 | (iterate f) 11 | (take-while identity))) 12 | 13 | (defn right-sib-zips 14 | [z] 15 | (->> z 16 | (iter-while-identity z/right) 17 | rest)) 18 | 19 | (defn left-sib-zips 20 | [z] 21 | (->> z 22 | (iter-while-identity z/left) 23 | rest)) 24 | 25 | (defn all-sib-zips [z] 26 | (let [lefty (z/leftmost z) 27 | zips (lazy-cat [lefty] (right-sib-zips lefty)) 28 | not-z #(not (= % z))] 29 | (filter not-z zips))) 30 | 31 | (defn ancestor-zips 32 | [z] 33 | (->> z 34 | (iter-while-identity z/up) 35 | rest)) 36 | 37 | (defn children-zips [zipr] 38 | (some->> zipr 39 | z/down 40 | (iter-while-identity z/right))) 41 | 42 | (defn children-zips-by-generation [zipr] 43 | (if (not-empty zipr) 44 | (let [zipr' (if (some-> zipr 45 | meta 46 | :zip/make-node) 47 | [zipr] 48 | zipr) 49 | kids (mapcat children-zips zipr')] 50 | (concat (if (not-empty kids) 51 | [kids] 52 | []) 53 | (children-zips-by-generation kids))) 54 | nil)) 55 | 56 | 57 | ;; === tags 58 | 59 | (defn get-tags 60 | [node pred-map] 61 | (vec (for [[kw pred] pred-map 62 | :when (pred node)] 63 | kw))) 64 | 65 | (defn get-tag-map 66 | [tree pred-map] 67 | (reduce (fn [tag-map node] 68 | (assoc tag-map 69 | (:id node) 70 | (get-tags node pred-map))) 71 | {} 72 | (tree-seq map? :children tree))) 73 | 74 | (defn mk-get-tag-fn 75 | [tag-map] 76 | (fn [tree] 77 | (-> tree 78 | :id 79 | tag-map))) 80 | 81 | ;; === zippers 82 | 83 | (defn tree->zipper 84 | [tree] 85 | (z/zipper map? 86 | #(-> % :children not-empty) 87 | #(assoc % :children %2) 88 | tree)) 89 | 90 | (defn traverse-assoc-zipper 91 | [zipr] 92 | (if (z/end? zipr) 93 | (-> zipr z/root) 94 | (recur (-> zipr 95 | (z/edit assoc :zipper zipr) 96 | z/next)))) 97 | 98 | (defn traverse-tree-assoc-zipper 99 | [tree] 100 | (-> tree 101 | tree->zipper 102 | traverse-assoc-zipper)) 103 | 104 | ;; move this to trace or utils? 105 | (defn traverse-tree 106 | [tree f] 107 | (assoc (f tree) 108 | :children (mapv #(traverse-tree % f) 109 | (:children tree)))) 110 | 111 | (defn traverse-tree-dissoc-zipper 112 | [tree] 113 | (traverse-tree tree #(dissoc % :zipper))) 114 | 115 | ;; === query 116 | 117 | (defn query-tree 118 | [qry-fn tree] 119 | (if-not (nil? tree) 120 | (let [e' (update-in tree [:children] 121 | (partial mapcat 122 | (partial query-tree 123 | qry-fn)))] 124 | (if (qry-fn tree) 125 | [e'] 126 | (:children e'))) 127 | [])) 128 | 129 | (defn query-dos 130 | [tree pred-map pred-final-fn] ;; pred-final-fn takes a node (w/ :zipper) and fn to retrieve tags from a node 131 | (let [tag-map (get-tag-map tree pred-map) 132 | get-tag-fn (mk-get-tag-fn tag-map) 133 | pred-final-fn' #(pred-final-fn % get-tag-fn)] 134 | (->> tree 135 | tree->zipper 136 | traverse-assoc-zipper 137 | (query-tree pred-final-fn')))) 138 | 139 | (defn query-uno 140 | [tree pred-fn] 141 | (query-tree pred-fn tree)) 142 | 143 | (defn query 144 | ([tree pred-fn] (query-uno tree pred-fn)) 145 | ([tree pred-map pred-final-fn] (query-dos tree pred-map pred-final-fn))) 146 | 147 | ;; === macro interface 148 | 149 | 150 | (defn get-some* 151 | [f v] 152 | (cond 153 | (fn? f) 154 | (f v) 155 | 156 | (and (var? f) 157 | (-> f deref fn?)) 158 | (f v) 159 | 160 | (set? f) 161 | (f v) 162 | 163 | :default 164 | (get v f))) 165 | 166 | (defn get-some 167 | [coll v] 168 | (loop [coll coll 169 | v v] 170 | (if ((some-fn empty? nil?) coll) 171 | v 172 | (let [[f & r] coll] 173 | (when-let [v' (get-some* f v)] 174 | (recur r v')))))) 175 | 176 | (defn eq* [pred v] 177 | (cond (fn? pred) 178 | (pred v) 179 | 180 | (and (var? pred) 181 | (-> pred deref fn?)) 182 | (pred v) 183 | 184 | (set? pred) 185 | (pred v) 186 | 187 | (instance? java.util.regex.Pattern pred) 188 | (->> v 189 | str 190 | (re-matches pred)) 191 | 192 | :default (= pred v))) 193 | 194 | (defn mk-query-fn 195 | [query-coll] 196 | (let [path (drop-last query-coll) 197 | pred (last query-coll)] 198 | (fn [v] 199 | (try 200 | (->> v 201 | (get-some path) 202 | (eq* pred)) 203 | (catch Exception ex 204 | nil))))) 205 | 206 | (defn some-mk-query-fn 207 | [queries] 208 | (->> queries 209 | (map mk-query-fn) 210 | (apply some-fn))) 211 | 212 | (defn every-pred-2 213 | [& preds] 214 | (fn [node tag-fn] 215 | (loop [[f & r] preds] 216 | (and (f node tag-fn) 217 | (if (not-empty r) 218 | (recur r) 219 | true))))) 220 | 221 | 222 | (defn mk-lazy-descendant-tag-seq 223 | [node tag-fn dist] 224 | (let [generations-seq (->> node 225 | :zipper 226 | children-zips-by-generation) 227 | g-seq (if dist 228 | (take dist generations-seq) 229 | generations-seq)] 230 | (->> g-seq 231 | (apply concat) 232 | (map z/node) 233 | (mapcat tag-fn)))) 234 | 235 | 236 | (defn mk-lazy-sibling-tag-seq 237 | [node tag-fn dist] 238 | (let [generations-seq (->> node 239 | :zipper 240 | all-sib-zips) 241 | g-seq (if dist 242 | (take dist generations-seq) 243 | generations-seq)] 244 | (->> g-seq 245 | (map z/node) 246 | (mapcat tag-fn)))) 247 | 248 | (defn mk-lazy-ancestor-tag-seq 249 | [node tag-fn dist] 250 | (let [generations-seq (->> node 251 | :zipper 252 | ancestor-zips) 253 | g-seq (if dist 254 | (take dist generations-seq) 255 | generations-seq)] 256 | (->> g-seq 257 | (map z/node) 258 | (mapcat tag-fn)))) 259 | 260 | (defn mk-relative-final-qry-fn 261 | [opts tag-set & [dist]] 262 | (fn [node tag-fn] 263 | (or (some tag-set (tag-fn node)) 264 | (let [opts' (if (some #{:w} opts) 265 | [:a :s :d] 266 | opts) 267 | rel-seq-map {:a mk-lazy-descendant-tag-seq 268 | :s mk-lazy-sibling-tag-seq 269 | :d mk-lazy-ancestor-tag-seq} 270 | tag-seq-coll (->> opts' 271 | (keep rel-seq-map) 272 | (mapv #(% node tag-fn dist)))] 273 | (some (partial some tag-set) 274 | tag-seq-coll))))) 275 | 276 | (defn parse-to-kw-chars 277 | [s] 278 | (->> s 279 | name 280 | seq 281 | (map str) 282 | (map keyword))) 283 | 284 | (defn query-dispatch-decider 285 | [_ body] 286 | (let [[f & r] body] 287 | (if (-> f 288 | type 289 | (= clojure.lang.PersistentVector)) 290 | :simple 291 | (let [kws (parse-to-kw-chars f)] 292 | (if (every? #{:a :s :d :w :r} 293 | kws) 294 | (condp some kws 295 | #{:a :s :d :w} :relative 296 | #{:r} :range) 297 | (throw (Exception. (format "Invalid query type '%s'" kws)))))))) 298 | 299 | (defmulti exec-query query-dispatch-decider) 300 | 301 | (defmethod exec-query :simple 302 | [tree body] 303 | (query tree 304 | (some-mk-query-fn body))) 305 | 306 | (defmethod exec-query :relative 307 | [tree [syms & r :as body]] 308 | (let [[fr & rr] r 309 | [dist pred-vecs] (if (number? fr) 310 | [fr rr] 311 | [nil r]) 312 | opts (parse-to-kw-chars syms) 313 | qry-final (mk-relative-final-qry-fn opts 314 | #{:a} 315 | dist)] 316 | (query tree 317 | {:a (some-mk-query-fn pred-vecs)} 318 | qry-final))) 319 | 320 | (defmethod exec-query :range 321 | [tree [_ ancestor descendant]] 322 | (query tree 323 | {:a (mk-query-fn ancestor) 324 | :d (mk-query-fn descendant)} 325 | (every-pred-2 (mk-relative-final-qry-fn [:d] #{:a}) 326 | (mk-relative-final-qry-fn [:a] #{:d})))) 327 | 328 | (defn mk-query-result-root 329 | [tree] 330 | (vary-meta (if (-> tree 331 | meta 332 | :trace-root) 333 | tree 334 | {:id (-> "query-result" gensym keyword) 335 | :children []}) 336 | assoc 337 | ::query-result true 338 | :trace-root true)) 339 | 340 | (defn q 341 | [tree & body] 342 | (let [parent (mk-query-result-root tree) 343 | [r1 :as result] (vec (exec-query tree 344 | body))] 345 | (if (= (:id r1) (:id parent)) 346 | r1 347 | (assoc parent 348 | :children result)))) 349 | 350 | ;; ======================== 351 | 352 | (defn get-pos 353 | [v] 354 | (-> (or (:src-pos v) 355 | (:meta v)) 356 | (select-keys [:line :column :file :end-line :end-column]) 357 | (assoc :ids #{(:id v)}))) 358 | 359 | (defn start-dist 360 | [pos-line {:keys [line end-line]}] 361 | (when (<= (or end-line line) pos-line) 362 | (- pos-line (or end-line line)))) 363 | 364 | (defn inside-width 365 | [pos-line {:keys [line end-line]}] 366 | (when (and end-line 367 | (<= line pos-line end-line)) 368 | (- end-line line))) 369 | 370 | (defn compare-metric 371 | [better worse] 372 | (cond 373 | (= nil better worse) nil 374 | (not better) false 375 | (not worse) true 376 | :else (< better worse))) 377 | 378 | (defn merge-em 379 | [a b] 380 | (assoc a 381 | :ids (->> [a b] 382 | (map :ids) 383 | (apply clojure.set/union)))) 384 | 385 | (def init-best {:ids #{} 386 | :line -1 387 | :end-line nil}) 388 | 389 | (defn compare-thing 390 | [line best next] 391 | (let [best (or best init-best) 392 | inside-width-best (inside-width line best) 393 | inside-width-next (inside-width line next) 394 | inside-width-best-better (compare-metric inside-width-best inside-width-next) 395 | inside-width-both-nil (= inside-width-best inside-width-next nil) 396 | inside-width-equal (= inside-width-best inside-width-next) 397 | start-dist-best (start-dist line best) 398 | start-dist-next (start-dist line next) 399 | start-dist-best-better (compare-metric start-dist-best start-dist-next) 400 | start-dist-both-nil (= start-dist-best start-dist-next nil) 401 | start-dist-equal (= start-dist-best start-dist-next)] 402 | (cond 403 | inside-width-best-better best 404 | 405 | (and (-> inside-width-best nil? not) 406 | inside-width-equal) 407 | (merge-em best next) 408 | 409 | (false? inside-width-best-better) next 410 | 411 | start-dist-best-better best 412 | start-dist-both-nil best 413 | start-dist-equal (merge-em best next) 414 | (false? start-dist-best-better) next))) 415 | 416 | (defn file-paths-match? 417 | [test path] 418 | (let [test' (clojure.string/replace test #"^file:" "") 419 | path' (clojure.string/replace path #"^file:" "")] 420 | (.endsWith test' path'))) 421 | 422 | (defn get-best-match-in-tree-seq 423 | [ts file line] 424 | (->> ts 425 | (map get-pos) 426 | (filter (fn [v] 427 | (when-let [f (:file v)] 428 | (file-paths-match? file f)))) 429 | (reduce (partial compare-thing 430 | line) 431 | init-best))) 432 | 433 | (defn get-ids-from-file-pos 434 | [tree file line] 435 | (util/$- ->> tree 436 | (tree-seq map? :children) 437 | (get-best-match-in-tree-seq $ file line) 438 | :ids)) 439 | 440 | (defn compare-positions-against-line-range 441 | [start-line line best next] 442 | (if (<= start-line 443 | (:line next)) 444 | (compare-thing line 445 | best 446 | next) 447 | best)) 448 | 449 | (defn get-best-match-in-tree-seq-for-line-range 450 | [ts file start-line line] 451 | (->> ts 452 | (map get-pos) 453 | (filter (fn [v] 454 | (when-let [f (:file v)] 455 | (file-paths-match? file f)))) 456 | (reduce (partial compare-positions-against-line-range 457 | start-line 458 | line) 459 | init-best))) 460 | 461 | (defn get-ids-from-file-line-range 462 | [tree file start-line line] 463 | (util/$- ->> tree 464 | (tree-seq map? :children) 465 | (get-best-match-in-tree-seq-for-line-range $ 466 | file 467 | start-line 468 | line) 469 | :ids)) 470 | -------------------------------------------------------------------------------- /test/com/billpiel/sayid/query_test.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.query-test 2 | (:require [clojure.test :as t] 3 | [com.billpiel.sayid.core :as sd] 4 | [com.billpiel.sayid.query2 :as q] 5 | [com.billpiel.sayid.test-utils :as t-utils])) 6 | 7 | (comment " 8 | 9 | A 10 | B C 11 | D E F 12 | G H I M N O 13 | J L 14 | 15 | ") 16 | 17 | (def test-trace {:id 1 18 | :name "A" 19 | :depth 0 20 | :args [1 2] 21 | :return 3 22 | :children [{:id 2 23 | :name "B" 24 | :depth 1 25 | :args [3 4 5] 26 | :return :b-return 27 | :children [{:id 10 28 | :name "D" 29 | :depth 2 30 | :args [] 31 | :return 4 32 | :children []} 33 | {:id 11 34 | :name "E" 35 | :depth 2 36 | :args [:a 1 :b 2] 37 | :return 5 38 | :children []}]} 39 | {:id 3 40 | :name "C" 41 | :depth 1 42 | :args [1 {:a [10 11 12]} 5] 43 | :return 8 44 | :children [{:id 4 45 | :name "F" 46 | :depth 2 47 | :args [2 5 9] 48 | :return "return F" 49 | :children [{:id 5 50 | :name "I" 51 | :depth 3 52 | :args [] 53 | :return 0 54 | :children [{:id 6 55 | :name "L" 56 | :depth 4 57 | :args [] 58 | :return 0 59 | :children []}]} 60 | {:id 7 61 | :name "M" 62 | :depth 3 63 | :args [] 64 | :return 0 65 | :children []} 66 | {:id 8 67 | :name "N" 68 | :depth 3 69 | :args [] 70 | :return 0 71 | :children []} 72 | {:id 9 73 | :name "O" 74 | :depth 3 75 | :args [] 76 | :return 0 77 | :children []}]}]}]}) 78 | 79 | (defn- fixture 80 | [f] 81 | (with-redefs [gensym (t-utils/mock-gensym-fn)] 82 | (f))) 83 | 84 | (t/use-fixtures :each fixture) 85 | 86 | (t/deftest simple 87 | (t/is (= (sd/tree-query test-trace [:depth 1]) 88 | {:id :query-result10, 89 | :children 90 | [{:id 2, 91 | :name "B", 92 | :depth 1, 93 | :args [3 4 5], 94 | :return :b-return, 95 | :children ()} 96 | {:id 3, 97 | :name "C", 98 | :depth 1, 99 | :args [1 {:a [10 11 12]} 5], 100 | :return 8, 101 | :children ()}]}))) 102 | 103 | (t/deftest range 104 | (t/is (= (q/traverse-tree-dissoc-zipper 105 | (sd/tree-query test-trace :r 106 | [:name "C"] 107 | [:name "I"])) 108 | {:id :query-result10, 109 | :children 110 | [{:id 3, 111 | :name "C", 112 | :depth 1, 113 | :args [1 {:a [10 11 12]} 5], 114 | :return 8, 115 | :children 116 | [{:id 4, 117 | :name "F", 118 | :depth 2, 119 | :args [2 5 9], 120 | :return "return F", 121 | :children 122 | [{:id 5, 123 | :name "I", 124 | :depth 3, 125 | :args [], 126 | :return 0, 127 | :children []}]}]}]}))) 128 | 129 | (t/deftest ancestors 130 | (t/is (= (q/traverse-tree-dissoc-zipper 131 | (sd/tree-query test-trace :a 132 | [:name "B"] 133 | [:name "I"])) 134 | {:id :query-result10, 135 | :children 136 | [{:id 1, 137 | :name "A", 138 | :depth 0, 139 | :args [1 2], 140 | :return 3, 141 | :children 142 | [{:id 2, 143 | :name "B", 144 | :depth 1, 145 | :args [3 4 5], 146 | :return :b-return, 147 | :children []} 148 | {:id 3, 149 | :name "C", 150 | :depth 1, 151 | :args [1 {:a [10 11 12]} 5], 152 | :return 8, 153 | :children 154 | [{:id 4, 155 | :name "F", 156 | :depth 2, 157 | :args [2 5 9], 158 | :return "return F", 159 | :children 160 | [{:id 5, 161 | :name "I", 162 | :depth 3, 163 | :args [], 164 | :return 0, 165 | :children []}]}]}]}]}))) 166 | 167 | 168 | (t/deftest descendants 169 | (t/is (= (q/traverse-tree-dissoc-zipper 170 | (sd/tree-query test-trace :d 171 | [:name "B"] 172 | [:name "I"])) 173 | {:id :query-result10, 174 | :children 175 | [{:id 2, 176 | :name "B", 177 | :depth 1, 178 | :args [3 4 5], 179 | :return :b-return, 180 | :children 181 | [{:id 10, :name "D", :depth 2, :args [], :return 4, :children []} 182 | {:id 11, 183 | :name "E", 184 | :depth 2, 185 | :args [:a 1 :b 2], 186 | :return 5, 187 | :children []}]} 188 | {:id 5, 189 | :name "I", 190 | :depth 3, 191 | :args [], 192 | :return 0, 193 | :children 194 | [{:id 6, 195 | :name "L", 196 | :depth 4, 197 | :args [], 198 | :return 0, 199 | :children []}]}]}))) 200 | 201 | (t/deftest descendants-limited-distance 202 | (t/is (= (q/traverse-tree-dissoc-zipper 203 | (sd/tree-query test-trace 204 | :d 1 205 | [:name "A"] 206 | [:name "C"])) 207 | {:id :query-result10, 208 | :children 209 | [{:id 1, 210 | :name "A", 211 | :depth 0, 212 | :args [1 2], 213 | :return 3, 214 | :children 215 | [{:id 2, 216 | :name "B", 217 | :depth 1, 218 | :args [3 4 5], 219 | :return :b-return, 220 | :children []} 221 | {:id 3, 222 | :name "C", 223 | :depth 1, 224 | :args [1 {:a [10 11 12]} 5], 225 | :return 8, 226 | :children 227 | [{:id 4, 228 | :name "F", 229 | :depth 2, 230 | :args [2 5 9], 231 | :return "return F", 232 | :children []}]}]}]}))) 233 | 234 | (t/deftest ancestors-and-descendants 235 | (t/is (= (q/traverse-tree-dissoc-zipper 236 | (sd/tree-query test-trace 237 | :ad 238 | [:name "E"] 239 | [:name "C"])) 240 | {:id :query-result10, 241 | :children 242 | [{:id 1, 243 | :name "A", 244 | :depth 0, 245 | :args [1 2], 246 | :return 3, 247 | :children 248 | [{:id 2, 249 | :name "B", 250 | :depth 1, 251 | :args [3 4 5], 252 | :return :b-return, 253 | :children 254 | [{:id 11, 255 | :name "E", 256 | :depth 2, 257 | :args [:a 1 :b 2], 258 | :return 5, 259 | :children []}]} 260 | {:id 3, 261 | :name "C", 262 | :depth 1, 263 | :args [1 {:a [10 11 12]} 5], 264 | :return 8, 265 | :children 266 | [{:id 4, 267 | :name "F", 268 | :depth 2, 269 | :args [2 5 9], 270 | :return "return F", 271 | :children 272 | [{:id 5, 273 | :name "I", 274 | :depth 3, 275 | :args [], 276 | :return 0, 277 | :children 278 | [{:id 6, 279 | :name "L", 280 | :depth 4, 281 | :args [], 282 | :return 0, 283 | :children []}]} 284 | {:id 7, 285 | :name "M", 286 | :depth 3, 287 | :args [], 288 | :return 0, 289 | :children []} 290 | {:id 8, 291 | :name "N", 292 | :depth 3, 293 | :args [], 294 | :return 0, 295 | :children []} 296 | {:id 9, 297 | :name "O", 298 | :depth 3, 299 | :args [], 300 | :return 0, 301 | :children []}]}]}]}]}))) 302 | 303 | (t/deftest ancestors-and-descendants-limited-distance 304 | (t/is (= (q/traverse-tree-dissoc-zipper 305 | (sd/tree-query test-trace 306 | :ad 2 307 | [:name "E"] 308 | [:name "C"])) 309 | {:id :query-result10, 310 | :children 311 | [{:id 1, 312 | :name "A", 313 | :depth 0, 314 | :args [1 2], 315 | :return 3, 316 | :children 317 | [{:id 2, 318 | :name "B", 319 | :depth 1, 320 | :args [3 4 5], 321 | :return :b-return, 322 | :children 323 | [{:id 11, 324 | :name "E", 325 | :depth 2, 326 | :args [:a 1 :b 2], 327 | :return 5, 328 | :children []}]} 329 | {:id 3, 330 | :name "C", 331 | :depth 1, 332 | :args [1 {:a [10 11 12]} 5], 333 | :return 8, 334 | :children 335 | [{:id 4, 336 | :name "F", 337 | :depth 2, 338 | :args [2 5 9], 339 | :return "return F", 340 | :children 341 | [{:id 5, 342 | :name "I", 343 | :depth 3, 344 | :args [], 345 | :return 0, 346 | :children []} 347 | {:id 7, 348 | :name "M", 349 | :depth 3, 350 | :args [], 351 | :return 0, 352 | :children []} 353 | {:id 8, 354 | :name "N", 355 | :depth 3, 356 | :args [], 357 | :return 0, 358 | :children []} 359 | {:id 9, 360 | :name "O", 361 | :depth 3, 362 | :args [], 363 | :return 0, 364 | :children []}]}]}]}]}))) 365 | 366 | (t/deftest wildcard 367 | (t/is (= (q/traverse-tree-dissoc-zipper 368 | (sd/tree-query test-trace 369 | :w 370 | [:name "I"])) 371 | {:id :query-result10, 372 | :children 373 | [{:id 1, 374 | :name "A", 375 | :depth 0, 376 | :args [1 2], 377 | :return 3, 378 | :children 379 | [{:id 3, 380 | :name "C", 381 | :depth 1, 382 | :args [1 {:a [10 11 12]} 5], 383 | :return 8, 384 | :children 385 | [{:id 4, 386 | :name "F", 387 | :depth 2, 388 | :args [2 5 9], 389 | :return "return F", 390 | :children 391 | [{:id 5, 392 | :name "I", 393 | :depth 3, 394 | :args [], 395 | :return 0, 396 | :children 397 | [{:id 6, 398 | :name "L", 399 | :depth 4, 400 | :args [], 401 | :return 0, 402 | :children []}]} 403 | {:id 7, 404 | :name "M", 405 | :depth 3, 406 | :args [], 407 | :return 0, 408 | :children []} 409 | {:id 8, 410 | :name "N", 411 | :depth 3, 412 | :args [], 413 | :return 0, 414 | :children []} 415 | {:id 9, 416 | :name "O", 417 | :depth 3, 418 | :args [], 419 | :return 0, 420 | :children []}]}]}]}]}))) 421 | 422 | (t/deftest wildcard-limited-distance 423 | (t/is (= (q/traverse-tree-dissoc-zipper 424 | (sd/tree-query test-trace 425 | :w 1 426 | [:name "I"])) 427 | {:id :query-result10, 428 | :children 429 | [{:id 4, 430 | :name "F", 431 | :depth 2, 432 | :args [2 5 9], 433 | :return "return F", 434 | :children 435 | [{:id 5, 436 | :name "I", 437 | :depth 3, 438 | :args [], 439 | :return 0, 440 | :children 441 | [{:id 6, 442 | :name "L", 443 | :depth 4, 444 | :args [], 445 | :return 0, 446 | :children []}]} 447 | {:id 7, :name "M", :depth 3, :args [], :return 0, :children []} 448 | {:id 8, :name "N", :depth 3, :args [], :return 0, :children []} 449 | {:id 9, 450 | :name "O", 451 | :depth 3, 452 | :args [], 453 | :return 0, 454 | :children []}]}]}))) 455 | 456 | (t/deftest siblings 457 | (t/is (= (q/traverse-tree-dissoc-zipper 458 | (sd/tree-query test-trace :s 459 | [:name "E"])) 460 | {:id :query-result10, 461 | :children 462 | [{:id 10, :name "D", :depth 2, :args [], :return 4, :children []} 463 | {:id 11, 464 | :name "E", 465 | :depth 2, 466 | :args [:a 1 :b 2], 467 | :return 5, 468 | :children []}]}))) 469 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Sayid logo](./sayid-logo.png) 2 | 3 | ---------- 4 | [![CircleCI](https://circleci.com/gh/clojure-emacs/sayid/tree/master.svg?style=svg)](https://circleci.com/gh/clojure-emacs/sayid/tree/master) 5 | [![Clojars Project](https://img.shields.io/clojars/v/com.billpiel/sayid.svg)](https://clojars.org/com.billpiel/sayid) 6 | [![cljdoc badge](https://cljdoc.org/badge/com.billpiel/sayid)](https://cljdoc.org/d/com.billpiel/sayid/CURRENT) 7 | 8 | Sayid *(siy EED)* is an omniscient debugger and profiler for Clojure. It extracts secrets from code at run-time. 9 | 10 | Sayid works by intercepting and recording the inputs and outputs of 11 | functions. It can even record function calls that occur inside of 12 | functions. The user can select which functions to trace. Functions can 13 | be selected individually or by namespace. The recorded data can be 14 | displayed, queried and profiled. 15 | 16 | Sayid currently has three components: 17 | 18 | * `sayid.core` and its supporting namespaces 19 | * [nREPL](https://nrepl.org) middleware 20 | * A [CIDER](https://cider.mx) plugin 21 | 22 | The `sayid.core` namespace is designed to be used directly via a REPL and does 23 | not require Emacs or CIDER. **BUT** the CIDER integration offers a far 24 | better experience, so it is the current focus of this page and my 25 | development efforts. 26 | 27 | **We're looking for more maintainers for the project. If you're interested in helping out please ping @bbatsov.** 28 | 29 | ## Installation & Requirements 30 | 31 | ### Requirements 32 | 33 | Basic usage requires Clojure 1.7 and the optional nREPL middleware requires nREPL 0.4+. 34 | 35 | nREPL-powered editor plugins are encouraged to make use of the bundled middleware that 36 | provides a very flexible Sayid API. 37 | 38 | ### Leiningen 39 | 40 | Add this to the dependencies in your project.clj or lein profiles.clj: 41 | 42 | [com.billpiel/sayid "0.1.0"] 43 | 44 | To use the bundled nREPL middleware, you'll want to include Sayid as a 45 | plug-in. Here's an example of a bare-bones profiles.clj that works for 46 | me: 47 | 48 | ```clojure 49 | {:user {:plugins [[com.billpiel/sayid "0.1.0"]]}} 50 | ``` 51 | 52 | ### Clojure CLI - deps.edn 53 | 54 | Add a the Sayid dependency to your `:deps` key. Depending on your 55 | desired setup, you may want to add it to an optional profile, or your 56 | tools.deps config directory (often `$HOME/.clojure`). 57 | 58 | ```clojure 59 | {:deps 60 | {com.billpiel/sayid {:mvn/version "0.1.0"}}} 61 | ``` 62 | 63 | ### Emacs Integration 64 | 65 | CIDER setup also requires that the Emacs package `sayid` is installed. It's 66 | available on [MELPA](https://melpa.org/#/sayid) and [MELPA 67 | Stable](https://stable.melpa.org/#/sayid). Put this code in `init.el`, or 68 | somewhere, to load keybindings for clojure-mode buffers. 69 | 70 | ```elisp 71 | (eval-after-load 'clojure-mode 72 | '(sayid-setup-package)) 73 | ``` 74 | 75 | If you use CIDER's jack-in commands, then Sayid automatically adds the 76 | Maven dependency when starting a REPL. This means you don't need to 77 | manually add the dependency to your `project.clj` or `deps.edn` file. 78 | 79 | If you don't use CIDER's jack-in commands, you'll need to add a 80 | dependency manually. Here's an example of a bare-bones profiles.clj 81 | that works for me: 82 | 83 | ```clojure 84 | {:user {:plugins [[cider/cider-nrepl "0.25.3"] 85 | [com.billpiel/sayid "0.1.0"]] 86 | :dependencies [[nrepl/nrepl "0.7.0"]]}} 87 | ``` 88 | 89 | Usually you'll want to use the latest versions of `cider-nrepl` and nREPL here. 90 | 91 | ### Other Editors 92 | 93 | A 3rd-party vim plugin also exists. See 94 | [this](http://arsenerei.com/blog/posts/2017-02-24-vim-sayid/) and 95 | [this](https://github.com/arsenerei/vim-sayid). 96 | 97 | ## Using Sayid 98 | 99 | **Note: This assumes you're using the official CIDER plugin.**. 100 | 101 | Documentation is a little light at the moment. There are lists of 102 | keybindings. Helpfully, they are easily accessible from within emacs. 103 | Below are the contents of the various help buffers, as well as 104 | instructions on how to pop them up in time of need. 105 | 106 | Generated docs are also available for the core namespace [here](doc). 107 | 108 | In a clojure-mode buffer, press `C-c s h` (`sayid-show-help`) to 109 | pop up the help buffer. 110 | 111 | C-c s ! -- Disable traces, eval current buffer, enable traces, clear the workspace log 112 | C-c s e -- Enables traces, evals the expression at point, disables traces, displays results with terse view 113 | C-c s f -- Queries the active workspace for entries that most closely match the context of the cursor position 114 | C-c s n -- Applies an inner trace to the function at point, replays workspace, displays results 115 | C-c s r -- Replays workspace, queries results by context of cursor 116 | C-c s w -- Shows workspace, using the current view 117 | C-c s t y -- Prompts for a dir, recursively traces all ns's in that dir and subdirs 118 | C-c s t p -- Prompts for a pattern (* = wildcare), and applies a trace to all *loaded* ns's whose name matches the patten 119 | C-c s t b -- Trace the ns in the current buffer 120 | C-c s t e -- Enable the *existing* (if any) trace of the function at point 121 | C-c s t E -- Enable all traces 122 | C-c s t d -- Disable the *existing* (if any) trace of the function at point 123 | C-c s t D -- Disable all traces 124 | C-c s t n -- Apply an inner trace to the symbol at point 125 | C-c s t o -- Apply an outer trace to the symbol at point 126 | C-c s t r -- Remove existing trace from the symbol at point 127 | C-c s t K -- Remove all traces 128 | C-c s c -- Clear the workspace trace log 129 | C-c s x -- Blow away workspace -- traces and logs 130 | C-c s s -- Popup buffer showing what it currently traced 131 | C-c s S -- Popup buffer showing what it currently traced in buffer's ns 132 | C-c s V s -- Set the view 133 | C-c s h -- show this help 134 | 135 | 136 | In the `*sayid*` buffer, press `h` to pop up the help buffer. 137 | 138 | ENTER -- pop to function 139 | d -- def value to $s/* 140 | f -- query for calls to function 141 | F -- query for calls to function with modifier 142 | i -- show only this instance 143 | I -- query for this instance with modifier 144 | w -- show full workspace trace 145 | n -- jump to next call node 146 | N -- apply inner trace and reply workspace 147 | p -- jump to prev call node 148 | P -- pretty print value 149 | C -- clear workspace trace log 150 | v -- toggle view 151 | V -- set view (see register-view) 152 | l, backspace -- previous buffer state 153 | L, S-backspace -- forward buffer state 154 | g -- generate instance expression and put in kill ring 155 | h -- help 156 | 157 | 158 | In the `*sayid-traced*` buffer, press `h` to pop up the help 159 | buffer. 160 | 161 | enter -- Drill into ns at point 162 | e -- Enable trace 163 | d -- Disable trace 164 | E -- Enable ALL traces 165 | D -- Disable ALL traces 166 | i -- Apply inner trace to func at point 167 | o -- Apply outer trace to func at point 168 | r -- Remove trace from fun at point 169 | l, backspace -- go back to trace overview (if in ns view) 170 | 171 | 172 | In the `*sayid-pprint*` buffer, press `h` to pop up the help 173 | buffer. 174 | 175 | ENTER -- show path in mini-buffer 176 | i -- jump into child node 177 | o -- jump out to parent node 178 | n -- jump to next sibling node 179 | p -- jump to previous sibling node 180 | 181 | ## Demos 182 | 183 | ### Conj 2016 Presentation 184 | 185 | I [presented Sayid](https://www.youtube.com/watch?v=ipDhvd1NsmE) at the Clojure 186 | Conj conference in Austin in 2016. 187 | 188 | [![Becoming Omniscient with Sayid - Bill 189 | Piel](http://img.youtube.com/vi/ipDhvd1NsmE/0.jpg)](http://www.youtube.com/watch?v=ipDhvd1NsmE 190 | "Becoming Omniscient with Sayid - Bill Piel") 191 | 192 | ### Demo \#1 - Video 193 | 194 | A [demo video](https://www.youtube.com/watch?v=wkduA4py-qk) I recorded after the 195 | very first alpha release. You can find the [contrived 196 | example](http://github.com/bpiel/contrived-example) project here. 197 | 198 | [![Sayid v0.0.1 - Demo 199 | #1](http://img.youtube.com/vi/wkduA4py-qk/0.jpg)](http://www.youtube.com/watch?v=wkduA4py-qk 200 | "Sayid v0.0.1 - Demo #1") 201 | 202 | ### Demo \#1 - Walkthrough 203 | 204 | This is a written walkthrough of the same steps illustrated in the demo 205 | video above, but with Sayid v0.0.8. You can find the [contrived 206 | example](http://github.com/bpiel/contrived-example) project here. 207 | 208 | Below is the code to the test namespace. You can see that we have a 209 | vending machine that dispenses tacos for 85 cents. We execute the 210 | `test1` function, which inserts 41 cents worth of change and presses the 211 | taco button. 212 | 213 | ```clojure 214 | (ns contrived-example.core-test 215 | (:require [clojure.test :refer :all] 216 | [contrived-example.core :as ce])) 217 | 218 | 219 | (def test-vending-machine {:inventory {:a1 {:name :taco 220 | :price 0.85 221 | :qty 10}} 222 | :coins-inserted [] 223 | :coins-returned [] 224 | :dispensed nil 225 | :err-msg nil}) 226 | 227 | (defn test1 [] 228 | (-> test-vending-machine 229 | (ce/insert-coin :quarter) ;; 25 230 | (ce/insert-coin :dime) ;; 35 231 | (ce/insert-coin :nickel) ;; 40 232 | (ce/insert-coin :penny) ;; 41 cents 233 | (ce/press-button :a1))) ;; taco costs 85 cents 234 | 235 | (test1) 236 | ``` 237 | 238 | Let's press some keys to get Sayid going. 239 | 240 | eval the namespace `C-c C-k` (probably) (`cider-load-buffer`) 241 | 242 | trace the project namespaces [C-c s t p]{.kbd} 243 | (`sayid-trace-ns-by-pattern`) then `contrived-example.*` 244 | 245 | This should pop up. It shows how many functions have been traced in 246 | which namespaces. Execute `test1`! 247 | 248 | Traced namespaces: 249 | 5 / 5 contrived-example.core 250 | 1 / 1 contrived-example.core-test 251 | 8 / 8 contrived-example.inner-workings 252 | 253 | 254 | Traced functions: 255 | 256 | You can't tell yet, but something magical happened. Press `C-c s 257 | w` (`sayid-get-workspace`) to get an overview of what has been 258 | captured in the Sayid workspace. This monster should appear: 259 | 260 | v contrived-example.core-test/test1 :13446 261 | |v contrived-example.core/insert-coin :13447 262 | |^ 263 | |v contrived-example.core/insert-coin :13448 264 | |^ 265 | |v contrived-example.core/insert-coin :13449 266 | |^ 267 | |v contrived-example.core/insert-coin :13450 268 | |^ 269 | |v contrived-example.core/press-button :13451 270 | ||v contrived-example.inner-workings/valid-selection :13452 271 | |||v contrived-example.inner-workings/get-selection :13453 272 | |||^ 273 | |||v contrived-example.inner-workings/calc-coin-value :13454 274 | |||^ 275 | ||| contrived-example.inner-workings/valid-selection :13452 276 | ||^ 277 | ||v contrived-example.inner-workings/process-transaction :13455 278 | |||v contrived-example.inner-workings/get-selection :13456 279 | |||^ 280 | |||v contrived-example.inner-workings/calc-change-to-return :13457 281 | ||||v contrived-example.inner-workings/calc-coin-value :13458 282 | ||||^ 283 | ||||v contrived-example.inner-workings/round-to-pennies :13459 284 | ||||^ 285 | ||||v contrived-example.inner-workings/calc-change-to-return* :13460 286 | |||||v contrived-example.inner-workings/calc-coin-value :13461 287 | |||||^ 288 | |||||v contrived-example.inner-workings/calc-change-to-return* :13462 289 | ||||||v contrived-example.inner-workings/calc-coin-value :13463 290 | ||||||^ 291 | ||||||v contrived-example.inner-workings/calc-change-to-return* :13464 292 | |||||||v contrived-example.inner-workings/calc-coin-value :13465 293 | |||||||^ 294 | |||||||v contrived-example.inner-workings/calc-change-to-return* :13466 295 | ||||||||v contrived-example.inner-workings/calc-coin-value :13467 296 | ||||||||^ 297 | |||||||| contrived-example.inner-workings/calc-change-to-return* :13466 298 | |||||||^ 299 | |||||||v contrived-example.inner-workings/calc-change-to-return* :13468 300 | ||||||||v contrived-example.inner-workings/calc-coin-value :13469 301 | ||||||||^ 302 | |||||||| contrived-example.inner-workings/calc-change-to-return* :13468 303 | |||||||^ 304 | |||||||v contrived-example.inner-workings/calc-change-to-return* :13470 305 | ||||||||v contrived-example.inner-workings/calc-coin-value :13471 306 | ||||||||^ 307 | |||||||| contrived-example.inner-workings/calc-change-to-return* :13470 308 | |||||||^ 309 | ||||||| contrived-example.inner-workings/calc-change-to-return* :13464 310 | ||||||^ 311 | |||||| contrived-example.inner-workings/calc-change-to-return* :13462 312 | |||||^ 313 | ||||| contrived-example.inner-workings/calc-change-to-return* :13460 314 | ||||^ 315 | |||| contrived-example.inner-workings/calc-change-to-return :13457 316 | |||^ 317 | ||| contrived-example.inner-workings/process-transaction :13455 318 | ||^ 319 | || contrived-example.core/press-button :13451 320 | |^ 321 | | contrived-example.core-test/test1 :13446 322 | ^ 323 | 324 | What's the meaning of this? These are all the function calls that were 325 | made in the traced namespaced when we execute `test1`. 326 | 327 | Let's explore. Get your cursor to the first line of the output and 328 | press `i` (`sayid-query-id`). 329 | 330 | v contrived-example.core-test/test1 :13446 331 | | returned => {:inventory {:a1 {:name :taco :price 0.85 :qty 9}} 332 | | :coins-inserted [] 333 | | :coins-returned [:quarter :quarter :nickel] 334 | | :dispensed {:name :taco :price 0.85 :qty 10} 335 | | :err-msg nil} 336 | ^ 337 | 338 | 339 | This shows us the details of that ***i**nstance* of `test1` being 340 | called. We can see that a hash map was returned. Despite us inserting 341 | only 41 cents for an 85 cent taco, we see that a taco was dispensed, 342 | plus change! That's a BUG. 343 | 344 | Hit `backspace` (`sayid-buf-back`). We're back at the overview. 345 | Scan the list of functions that are called. Let's assume some 346 | programmer's intuition and decide that `valid-selection` is the first 347 | place of interest. Get your cursor to that line and press these keys to 348 | view the ***i**nstance* and all of its ***d**escendants*. `I` 349 | `d` `ENTER (`sayid-query-id-w-mode`) 350 | 351 | ||v contrived-example.inner-workings/valid-selection :13452 352 | ||| machine => {:inventory {:a1 {:name :taco :price 0.85 :qty 10}} 353 | ||| :coins-inserted [:quarter :dime :nickel :penny] 354 | ||| :coins-returned [] 355 | ||| :dispensed nil 356 | ||| :err-msg nil} 357 | ||| button => :a1 358 | ||| returns => true 359 | |||v contrived-example.inner-workings/get-selection :13453 360 | |||| machine => {:inventory {:a1 {:name :taco :price 0.85 :qty 10}} 361 | |||| :coins-inserted [:quarter :dime :nickel :penny] 362 | |||| :coins-returned [] 363 | |||| :dispensed nil 364 | |||| :err-msg nil} 365 | |||| button => :a1 366 | |||| returned => {:name :taco :price 0.85 :qty 10} 367 | |||^ 368 | |||v contrived-example.inner-workings/calc-coin-value :13454 369 | |||| coins => [:quarter :dime :nickel :penny] 370 | |||| returned => 1.4 371 | |||^ 372 | ||| contrived-example.inner-workings/valid-selection :13452 373 | ||| machine => {:inventory {:a1 {:name :taco :price 0.85 :qty 10}} 374 | ||| :coins-inserted [:quarter :dime :nickel :penny] 375 | ||| :coins-returned [] 376 | ||| :dispensed nil 377 | ||| :err-msg nil} 378 | ||| button => :a1 379 | ||| returned => true 380 | ||^ 381 | 382 | We can see that `valid-selection` makes calls to `get-selection` and 383 | `calc-coin-value`. Looking at the return values, we might notice a 384 | problem: `calc-coin-value` receives 385 | `[:quarter :dime :nickel :penny]` but returns 386 | \$1.40 as the value. Let's dig deeper. Press `n` 387 | (`sayid-buffer-nav-to-next`) a couple times to get the cursor to the 388 | call to `calc-coin-value`. Now press `N` 389 | (`sayid-buf-replay-with-inner-trace`) and hold onto your hat. 390 | 391 | ||||v (->> coins (keep coin-values) (apply +)) => (apply + (keep coin-values coins)) contrived-example.inner-workings/calc-coin-value :13491 392 | ||||| returns => 1.4 393 | |||||v (apply + (keep coin-values coins)) contrived-example.inner-workings/calc-coin-value :13492 394 | |||||| #function[clojure.core/+] 395 | |||||| (0.25 0.1 0.05 1) 396 | |||||| returns => 1.4 397 | ||||||v (keep coin-values coins) contrived-example.inner-workings/calc-coin-value :13493 398 | ||||||| {:quarter 0.25 :dime 0.1 :nickel 0.05 :penny 1} 399 | ||||||| [:quarter :dime :nickel :penny] 400 | ||||||| returned => (0.25 0.1 0.05 1) 401 | ||||||^ 402 | |||||| (apply + (keep coin-values coins)) contrived-example.inner-workings/calc-coin-value :13492 403 | |||||| #function[clojure.core/+] 404 | |||||| (0.25 0.1 0.05 1) 405 | |||||| returned => 1.4 406 | |||||^ 407 | ||||| (->> coins (keep coin-values) (apply +)) => (apply + (keep coin-values coins)) contrived-example.inner-workings/calc-coin-value :13491 408 | ||||| returned => 1.4 409 | ||||^ 410 | ...truncated... 411 | 412 | *(jump to the top of the buffer)* 413 | 414 | What did we do? We applied an *inner trace* to the function 415 | `calc-coin-value` and then replayed the call to `test1` that we had 416 | captured originally. 417 | 418 | **An INNER trace?** YES! We can see the inputs and output values of 419 | each expression in the function. Look at it. Where do things go wrong? 420 | It's when we pass a hash map to `keep` that defines a penny as being 421 | worth a dollar. Bug located! Press `n` a couple times to get your 422 | cursor to that call. Press `RET` to jump to that line of code. 423 | 424 | ```clojure 425 | (ns contrived-example.inner-workings) 426 | 427 | (def coin-values 428 | {:quarter 0.25 429 | :dime 0.10 430 | :nickel 0.05 431 | :penny 1}) 432 | 433 | (defn- calc-coin-value 434 | [coins] 435 | (->> coins 436 | (keep coin-values) 437 | (apply +))) 438 | 439 | ...truncated... 440 | ``` 441 | 442 | We now find ourselves at the troublesome call to `keep` causing our bug. 443 | The hash map, `coin-values`, is just above. Change the value of a penny 444 | from `1` to `0.01`. Let's eval our corrected code the Sayid way \-- 445 | press `C-c s !` (`sayid-load-enable-clear`). This will remove the 446 | traces, eval the buffer, then re-apply the traces. It also clears the 447 | workspace log. This is all helpful. Navigate back to `core-test` and run 448 | `test1` again. Repeating steps above, you can verify the output is now 449 | correct: no taco. 450 | 451 | v contrived-example.core-test/test1 :13579 452 | | returned => {:inventory {:a1 {:name :taco :price 0.85 :qty 10}} 453 | | :coins-inserted [:quarter :dime :nickel :penny] 454 | | :coins-returned [] 455 | | :dispensed nil 456 | | :err-msg true} 457 | ^ 458 | 459 | Great work! 460 | 461 | ## License 462 | 463 | Distributed under the Apache 2.0 License. See [LICENSE](LICENSE) for details. 464 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/nrepl_middleware.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.nrepl-middleware 2 | (:require 3 | [clojure.stacktrace :as st] 4 | [clojure.tools.namespace.find :as ns-find] 5 | [clojure.tools.reader :as r] 6 | [clojure.tools.reader.reader-types :as rts] 7 | [com.billpiel.sayid.core :as sd] 8 | [com.billpiel.sayid.query2 :as q] 9 | [com.billpiel.sayid.string-output2 :as so] 10 | [com.billpiel.sayid.trace :as tr] 11 | [com.billpiel.sayid.util.find-ns :as find-ns] 12 | [com.billpiel.sayid.util.other :as util] 13 | [com.billpiel.sayid.view :as v] 14 | [nrepl.middleware :refer [set-descriptor!]] 15 | [nrepl.misc :refer [response-for]] 16 | [nrepl.transport :as t] 17 | [tamarin.core :as tam])) 18 | 19 | (def views (atom {})) 20 | (def selected-view (atom nil)) 21 | 22 | 23 | (defn try-find-ns-root 24 | [ns-sym] 25 | (let [depth (some-> ns-sym str (clojure.string/split #"\.") count)] 26 | (util/$- some-> ns-sym ns-interns vals first meta :file (clojure.string/split #"/") (drop-last depth $) (clojure.string/join "/" $)))) 27 | 28 | (defn find-all-ns-roots 29 | [] 30 | (some->> (all-ns) (map str) (map symbol) (map try-find-ns-root) distinct (remove empty?))) 31 | 32 | 33 | (defn register-view! 34 | [name view] 35 | (swap! views 36 | assoc 37 | name 38 | view)) 39 | 40 | (defn query* 41 | [& args] 42 | (if args 43 | (assoc (apply sd/ws-query* 44 | args) 45 | ::query-args 46 | args) 47 | (assoc (sd/ws-view!) 48 | ::query-args 49 | nil))) 50 | 51 | (defn query-tree->trio 52 | [tree] 53 | (conj (vec (so/tree->text-prop-pair tree)) 54 | (-> tree ::query-args pr-str))) 55 | 56 | (defn clj->nrepl* 57 | [v] 58 | (cond (coll? v) (list* v) 59 | (number? v) v 60 | (keyword? v) (name v) 61 | (true? v) 1 62 | (false? v) nil 63 | :else (str v))) 64 | 65 | (defn clj->nrepl 66 | [frm] 67 | (clojure.walk/prewalk clj->nrepl* 68 | frm)) 69 | 70 | (defn send-status-done 71 | [msg] 72 | (t/send (:transport msg) 73 | (response-for msg :status :done))) 74 | 75 | (defn reply:clj->nrepl 76 | [msg out] 77 | (try (t/send (:transport msg) 78 | (response-for msg 79 | :value (clj->nrepl out))) 80 | (catch Exception e 81 | (println "EXCEPTION!") 82 | (println e))) 83 | (send-status-done msg)) 84 | 85 | (defn find-ns-sym 86 | [file] 87 | (some->> file 88 | slurp 89 | (re-find #"\(ns\s+(.+)\b") 90 | second 91 | symbol)) 92 | 93 | (defn get-top-form-at-pos-in-source 94 | [file line source] 95 | (let [rdr (rts/source-logging-push-back-reader source 96 | (count source) 97 | file)] 98 | (loop [rdr-iter rdr] 99 | (let [frm (r/read rdr) 100 | m (meta frm)] 101 | (cond 102 | (nil? frm) nil 103 | (<= (:line m) line (:end-line m)) frm 104 | (> (:line m) line) nil 105 | :else (recur rdr-iter)))))) 106 | 107 | (defn get-meta-at-pos-in-source 108 | [file line source] 109 | (meta (get-top-form-at-pos-in-source file line source))) 110 | 111 | (defn pos-inside-line-column? 112 | [pos-line pos-column start-line end-line start-col end-col] 113 | (if (= start-line pos-line end-line) 114 | (<= start-col pos-column end-col) 115 | (or (and (= start-line pos-line) 116 | (<= start-col pos-column)) 117 | (and (= end-line pos-line) 118 | (< pos-column end-col)) 119 | (< start-line pos-line end-line)))) 120 | 121 | (defn get-sym-at-pos-in-source 122 | [file pos-line pos-column source] 123 | (let [tseq (tree-seq coll? seq (get-top-form-at-pos-in-source file pos-line source)) 124 | inside? (fn [sym] 125 | (let [{:keys [line end-line column end-column]} (meta sym)] 126 | (when line 127 | (pos-inside-line-column? pos-line 128 | pos-column 129 | line 130 | end-line 131 | column 132 | end-column))))] 133 | (last (filter inside? tseq)))) 134 | 135 | (defn parse-ns-name-from-source ;; TODO don't use this 136 | [source] 137 | (second (re-find #"\(\s*ns\s+([\w$.*-]+)" 138 | source))) 139 | 140 | (defn ^:nrepl sayid-version 141 | [msg] 142 | (reply:clj->nrepl msg sd/version)) 143 | 144 | (defn ^:nrepl sayid-trace-fn-enable-at-point 145 | [{:keys [transport file line column source] :as msg}] 146 | (let [sym (get-sym-at-pos-in-source file line column source) 147 | ns-sym (symbol (parse-ns-name-from-source source)) 148 | qual-sym 149 | (util/resolve-to-qual-sym ns-sym sym)] 150 | (when qual-sym 151 | (sd/ws-enable-trace-fn! qual-sym)) 152 | (reply:clj->nrepl msg qual-sym))) 153 | 154 | 155 | (defn ^:nrepl sayid-trace-fn-disable-at-point 156 | [{:keys [transport file line column source] :as msg}] 157 | (let [sym (get-sym-at-pos-in-source file line column source) 158 | ns-sym (symbol (parse-ns-name-from-source source)) 159 | qual-sym 160 | (util/resolve-to-qual-sym ns-sym sym)] 161 | (when qual-sym 162 | (sd/ws-disable-trace-fn! qual-sym)) 163 | (reply:clj->nrepl msg qual-sym))) 164 | 165 | (defn ^:nrepl sayid-trace-fn-outer-trace-at-point 166 | [{:keys [transport file line column source] :as msg}] 167 | (let [sym (get-sym-at-pos-in-source file line column source) 168 | ns-sym (symbol (parse-ns-name-from-source source)) 169 | qual-sym 170 | (util/resolve-to-qual-sym ns-sym sym)] 171 | (when qual-sym 172 | (sd/ws-add-trace-fn!* qual-sym)) 173 | (reply:clj->nrepl msg qual-sym))) 174 | 175 | (defn ^:nrepl sayid-trace-fn-inner-trace-at-point 176 | [{:keys [transport file line column source] :as msg}] 177 | (let [sym (get-sym-at-pos-in-source file line column source) 178 | ns-sym (symbol (parse-ns-name-from-source source)) 179 | qual-sym 180 | (util/resolve-to-qual-sym ns-sym sym)] 181 | (when qual-sym 182 | (sd/ws-add-inner-trace-fn!* qual-sym)) 183 | (reply:clj->nrepl msg qual-sym))) 184 | 185 | (defn ^:nrepl sayid-remove-trace-fn-at-point 186 | [{:keys [transport file line column source] :as msg}] 187 | (let [sym (get-sym-at-pos-in-source file line column source) 188 | ns-sym (symbol (parse-ns-name-from-source source)) 189 | qual-sym 190 | (util/resolve-to-qual-sym ns-sym sym)] 191 | (when qual-sym 192 | (sd/ws-remove-trace-fn! qual-sym)) 193 | (reply:clj->nrepl msg qual-sym))) 194 | 195 | (defn tree-contains-inner-trace? 196 | [tree] 197 | (->> tree 198 | (tree-seq map? :children) 199 | (filter #(contains? % :src-pos)) 200 | first 201 | nil? 202 | not)) 203 | 204 | (defn query-ws-by-file-line-range 205 | "Find the tree node that: is smallest or starts latest, contains line 206 | and starts at or after start-line." 207 | [file start-line line] 208 | (let [ws (sd/ws-deref!) 209 | ids (q/get-ids-from-file-line-range ws 210 | file 211 | (or start-line line) 212 | line)] 213 | (if-not (empty? ids) 214 | (query* [:id ids]) 215 | nil))) 216 | 217 | (defn process-line-meta 218 | [line-meta] 219 | (mapv (fn [[n m]] 220 | [n 221 | (-> m 222 | (update-in [:path] str) 223 | (update-in [:header] #(when % 1)))]) 224 | line-meta)) 225 | 226 | ;; ====================== 227 | 228 | (defn ^:nrepl sayid-set-view 229 | [{:keys [transport view-name] :as msg}] 230 | 231 | (-> view-name keyword (@views) sd/set-view!) 232 | (reset! selected-view @sd/view) 233 | (send-status-done msg)) 234 | 235 | (defn ^:nrepl sayid-toggle-view 236 | [{:keys [transport] :as msg}] 237 | (if (and @selected-view 238 | (not= @sd/view @selected-view)) 239 | (do (sd/set-view! @selected-view) 240 | (reply:clj->nrepl msg 1)) 241 | (do (sd/set-view!) 242 | (reply:clj->nrepl msg 0))) 243 | (send-status-done msg)) 244 | 245 | (defn ^:nrepl sayid-get-views 246 | [{:keys [transport source file line] :as msg}] 247 | (reply:clj->nrepl msg (keys @views))) 248 | 249 | (defn ^:nrepl sayid-get-meta-at-point 250 | [{:keys [transport source file line] :as msg}] 251 | (t/send transport 252 | (response-for msg 253 | :value (str (get-meta-at-pos-in-source file line source)))) 254 | (send-status-done msg)) 255 | 256 | (defn ^:nrepl sayid-show-traced 257 | [{:keys [transport ns] :as msg}] 258 | (let [audit (-> @sd/workspace :traced tr/audit-traces) 259 | audit-view (if (not (or (nil? ns) (empty? ns))) 260 | (so/audit->ns-view audit (symbol ns)) 261 | (so/audit->top-view audit))] 262 | (->> audit-view 263 | so/tokens->text-prop-pair 264 | (reply:clj->nrepl msg)))) 265 | 266 | (defn count-traces 267 | [trace-audit] 268 | (+ (count (for [v1 (-> trace-audit :ns vals) 269 | v2 (vals v1)] 270 | v2)) 271 | (count (for [v1 (-> trace-audit :fn vals) 272 | v2 (vals v1)] 273 | v2)))) 274 | 275 | (defn count-enabled-traces 276 | [trace-audit] 277 | (+ (count (for [v1 (-> trace-audit :ns vals) 278 | v2 (vals v1) 279 | :when (-> v2 :trace-type nil? not)] 280 | v2)) 281 | (count (for [v1 (-> trace-audit :fn vals) 282 | v2 (vals v1) 283 | :when (-> v2 :trace-type nil? not)] 284 | v2)))) 285 | 286 | (defn ^:nrepl sayid-get-trace-count 287 | [{:keys [transport] :as msg}] 288 | (util/$- -> @sd/workspace 289 | :traced 290 | tr/audit-traces 291 | count-traces 292 | (reply:clj->nrepl msg $))) 293 | 294 | (defn ^:nrepl sayid-get-enabled-trace-count 295 | [{:keys [transport] :as msg}] 296 | (util/$- -> @sd/workspace 297 | :traced 298 | tr/audit-traces 299 | count-enabled-traces 300 | (reply:clj->nrepl msg $))) 301 | 302 | (defn ^:nrepl sayid-trace-fn 303 | [{:keys [transport fn-name fn-ns type] :as msg}] 304 | (case type 305 | "outer" (sd/ws-add-trace-fn!* (util/qualify-sym fn-ns fn-name)) 306 | "inner" (sd/ws-add-inner-trace-fn!* (util/qualify-sym fn-ns fn-name))) 307 | (send-status-done msg)) 308 | 309 | (defn ^:nrepl sayid-trace-fn-enable 310 | [{:keys [transport fn-name fn-ns] :as msg}] 311 | (sd/ws-enable-trace-fn! (util/qualify-sym fn-ns fn-name)) 312 | (send-status-done msg)) 313 | 314 | (defn ^:nrepl sayid-trace-fn-disable 315 | [{:keys [transport fn-name fn-ns] :as msg}] 316 | (sd/ws-disable-trace-fn! (util/qualify-sym fn-ns fn-name)) 317 | (send-status-done msg)) 318 | 319 | (defn ^:nrepl sayid-trace-fn-remove 320 | [{:keys [transport fn-name fn-ns] :as msg}] 321 | (sd/ws-remove-trace-fn! (util/qualify-sym fn-ns fn-name)) 322 | (send-status-done msg)) 323 | 324 | (defn ^:nrepl sayid-trace-ns-enable 325 | [{:keys [transport fn-ns] :as msg}] 326 | (sd/ws-enable-trace-ns! (symbol fn-ns)) 327 | (send-status-done msg)) 328 | 329 | (defn ^:nrepl sayid-trace-ns-disable 330 | [{:keys [transport fn-ns] :as msg}] 331 | (sd/ws-disable-trace-ns! (symbol fn-ns)) 332 | (send-status-done msg)) 333 | 334 | (defn ^:nrepl sayid-trace-ns-remove 335 | [{:keys [transport fn-ns] :as msg}] 336 | (sd/ws-remove-trace-ns! (symbol fn-ns)) 337 | (send-status-done msg)) 338 | 339 | (defn ^:nrepl sayid-query-form-at-point 340 | [{:keys [file line] :as msg}] 341 | (reply:clj->nrepl msg 342 | (-> (sd/ws-query-by-file-pos file line) 343 | so/tree->text-prop-pair))) 344 | 345 | (defn sayid-buf-query 346 | [q-vec mod-str] 347 | (let [[_ sk sn] (re-find #"(\w+)\s*(\d+)?" mod-str) 348 | k (keyword sk) 349 | n (util/->int sn) 350 | query (remove nil? [k n q-vec])] 351 | (sd/with-view (->> query 352 | (apply query*) 353 | query-tree->trio)))) 354 | 355 | (defn ^:nrepl sayid-buf-query-id-w-mod 356 | [{:keys [trace-id mod] :as msg}] 357 | (reply:clj->nrepl msg 358 | (sayid-buf-query [:id (keyword trace-id)] 359 | mod))) 360 | 361 | (def parent-name-or-name (some-fn :parent-name :name)) 362 | 363 | (defn ^:nrepl sayid-buf-query-fn-w-mod 364 | [{:keys [fn-name mod] :as msg}] 365 | (reply:clj->nrepl msg (sayid-buf-query [#'parent-name-or-name 366 | (symbol fn-name)] 367 | mod))) 368 | 369 | ;; this func is unfortunate 370 | (defn str-vec->arg-path 371 | [[kw & idx]] 372 | (let [kw' (keyword kw) 373 | str->sym (fn [s] (if (string? s) 374 | (symbol s) 375 | s))] 376 | (into [kw'] (mapv str->sym idx)))) 377 | 378 | ;; ===== gen-instance-expr helpers 379 | 380 | (defn find-arg-list-by-length 381 | [n [first-list & rest-lists]] 382 | (let [cfl (count first-list)] 383 | (cond (nil? first-list) nil 384 | 385 | (or (= n cfl) 386 | (and (-> first-list reverse rest first (= '&)) 387 | (>= n (dec cfl)))) 388 | first-list 389 | 390 | :else (recur n rest-lists)))) 391 | 392 | (defn get-args-sym-template 393 | [arglist] 394 | (let [convert-non-syms (fn [v] (if (symbol? v) 395 | v 396 | '*))] 397 | (util/$- ->> arglist 398 | (remove #{'&}) 399 | (map convert-non-syms) 400 | (concat $ (repeat (last $)))))) 401 | 402 | (defn find-available-sym 403 | [ns-sym prefix & [init-taken]] 404 | (let [taken (set (or init-taken 405 | (-> ns-sym 406 | create-ns 407 | ns-interns 408 | keys)))] 409 | (loop [n 0] 410 | (let [suffix (if (= n 0) "" n) 411 | candidate (symbol (str prefix suffix))] 412 | (if-not (taken candidate) 413 | candidate 414 | (recur (inc n))))))) 415 | 416 | (defn lazy-find-available-sym 417 | [prefix-seq init-taken] 418 | (let [next (find-available-sym nil (first prefix-seq) init-taken)] 419 | (lazy-cat [next] 420 | (lazy-find-available-sym (rest prefix-seq) 421 | (conj init-taken next))))) 422 | 423 | 424 | (defn mk-avail-sym-lazy-seq 425 | [n arglists] 426 | (lazy-find-available-sym (get-args-sym-template (find-arg-list-by-length n 427 | arglists)) 428 | (-> '$s 429 | create-ns 430 | ns-interns 431 | keys 432 | (or [])))) 433 | 434 | ;; END ===== gen-instance-expr helpers 435 | 436 | (defn gen-instance-expr 437 | [tree] 438 | (let [arg-count (-> tree :args count) 439 | arglists (-> tree :meta :arglists) 440 | arglist-template-seq (mk-avail-sym-lazy-seq arg-count 441 | arglists)] 442 | (doseq [pair (map vector 443 | arglist-template-seq 444 | (:args tree))] 445 | (apply util/def-ns-var 446 | '$s 447 | pair)) 448 | (format "(%s%s)" 449 | (-> tree :meta :name) 450 | (apply str (interleave (repeat " $s/") 451 | (take arg-count arglist-template-seq)))))) 452 | 453 | (defn ^:nrepl sayid-find-all-ns-roots 454 | [{:keys [transport] :as msg}] 455 | (reply:clj->nrepl msg (find-all-ns-roots))) 456 | 457 | (defn ^:nrepl sayid-gen-instance-expr 458 | [{:keys [transport trace-id] :as msg}] 459 | (or (some->> (sd/ws-query* [:id (keyword trace-id)]) 460 | :children 461 | first 462 | gen-instance-expr 463 | (reply:clj->nrepl msg)) 464 | (send-status-done msg))) 465 | 466 | (defn ^:nrepl sayid-buf-def-at-point 467 | [{:keys [transport trace-id path] :as msg}] 468 | (let [path' (str-vec->arg-path path)] 469 | (util/def-ns-var '$s '* (-> [:id (keyword trace-id)] 470 | sd/ws-query* 471 | :children 472 | first 473 | (get-in path')))) 474 | (t/send transport (response-for msg :value "Def'd as $s/*")) 475 | (send-status-done msg)) 476 | 477 | (defn ^:nrepl sayid-buf-pprint-at-point 478 | [{:keys [transport trace-id path] :as msg}] 479 | (let [path' (str-vec->arg-path path) 480 | value (-> [:id (keyword trace-id)] 481 | sd/ws-query* 482 | :children 483 | first 484 | (get-in path'))] 485 | (binding [tam/*max-y* 5000 486 | tam/*max-seq-items* 100] 487 | (->> value 488 | so/value->text-prop-pair* 489 | (reply:clj->nrepl msg))))) 490 | 491 | (defn ^:nrepl sayid-clear-log 492 | [{:keys [transport] :as msg}] 493 | (sd/ws-clear-log!) 494 | (send-status-done msg)) 495 | 496 | (defn ^:nrepl sayid-reset-workspace 497 | [{:keys [transport] :as msg}] 498 | (sd/ws-reset!) 499 | (send-status-done msg)) 500 | 501 | (defn ^:nrepl sayid-trace-all-ns-in-dir 502 | [{:keys [transport dir] :as msg}] 503 | (doall (map sd/ws-add-trace-ns!* 504 | (ns-find/find-namespaces-in-dir (java.io.File. dir)))) 505 | (sd/ws-cycle-all-traces!) 506 | (send-status-done msg)) 507 | 508 | (defn ^:nrepl sayid-trace-ns-by-pattern 509 | [{:keys [transport ns-pattern ref-ns] :as msg}] 510 | (mapv #(-> % 511 | str 512 | symbol 513 | sd/ws-add-trace-ns!*) 514 | (find-ns/search-nses (symbol ns-pattern) 515 | (symbol ref-ns))) 516 | (sd/ws-cycle-all-traces!) 517 | (send-status-done msg)) 518 | 519 | (defn ^:nrepl sayid-trace-ns-in-file 520 | [{:keys [transport file] :as msg}] 521 | (->> file 522 | find-ns-sym 523 | sd/ws-add-trace-ns!*) 524 | (send-status-done msg)) 525 | 526 | (defn ^:nrepl sayid-remove-all-traces 527 | [{:keys [transport] :as msg}] 528 | (sd/ws-remove-all-traces!) 529 | (send-status-done msg)) 530 | 531 | (defn ^:nrepl sayid-disable-all-traces 532 | [{:keys [transport] :as msg}] 533 | (sd/ws-disable-all-traces!) 534 | (send-status-done msg)) 535 | 536 | (defn ^:nrepl sayid-enable-all-traces 537 | [{:keys [transport] :as msg}] 538 | (sd/ws-enable-all-traces!) 539 | (send-status-done msg)) 540 | 541 | (defn ^:nrepl sayid-get-workspace 542 | [msg] 543 | (reply:clj->nrepl msg 544 | (sd/with-this-view (or @sd/view 545 | (v/mk-simple-view {})) 546 | (query-tree->trio (sd/ws-view!))))) 547 | 548 | (defn magic-recusive-eval 549 | "Lets us send vars to nrepl client and back. Madness." 550 | [frm] 551 | (cond (vector? frm) (mapv magic-recusive-eval frm) 552 | (seq? frm) (eval frm) 553 | :else frm)) 554 | 555 | (defn ^:nrepl sayid-query 556 | [{:keys [transport query] :as msg}] 557 | ;; TODO default to name-only view for empty query? 558 | (sd/with-view (->> query 559 | read-string 560 | (map magic-recusive-eval) 561 | (apply query*) 562 | query-tree->trio 563 | (reply:clj->nrepl msg)))) 564 | 565 | (def sayid-nrepl-ops 566 | (->> *ns* 567 | ns-interns 568 | vals 569 | (filter #(-> % meta :nrepl)) 570 | (map #(vector (-> % meta :name str) %)) 571 | (into {}))) 572 | 573 | (defn wrap-sayid 574 | [handler] 575 | (fn [{:keys [op] :as msg}] 576 | (try 577 | ((get sayid-nrepl-ops op handler) msg) 578 | (catch Throwable e 579 | (println (.getMessage e)) 580 | (st/print-stack-trace e) 581 | (reply:clj->nrepl msg (.getMessage e)))))) 582 | 583 | 584 | (set-descriptor! #'wrap-sayid 585 | {:handles (zipmap (keys sayid-nrepl-ops) 586 | (repeat {:doc "docs?" 587 | :returns {} 588 | :requires {}}))}) 589 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/core.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.core 2 | (:require [clojure.java.io :as io] 3 | [com.billpiel.sayid.trace :as trace] 4 | [com.billpiel.sayid.inner-trace3 :as itrace] 5 | [com.billpiel.sayid.workspace :as ws] 6 | [com.billpiel.sayid.recording :as rec] 7 | [com.billpiel.sayid.query2 :as q] 8 | [com.billpiel.sayid.view :as v] 9 | [com.billpiel.sayid.util.find-ns :as find-ns] 10 | [com.billpiel.sayid.string-output2 :as so] 11 | [com.billpiel.sayid.profiling :as pro] 12 | [com.billpiel.sayid.util.other :as util])) 13 | 14 | (def version 15 | "The current version of sayid as a string." 16 | (-> (or (io/resource "META-INF/leiningen/com.billpiel/sayid/project.clj") 17 | "project.clj") 18 | slurp 19 | read-string 20 | (nth 2))) 21 | 22 | (def workspace 23 | "The active workspace. Used by default in any function prefixed `ws-` 24 | or `w-`." 25 | (atom nil)) 26 | 27 | (def recording 28 | "The active recording. Used by default in any function prefixed `rec-` 29 | or `r-`." 30 | (atom nil)) 31 | 32 | (def view (atom nil)) 33 | (def ^:dynamic *view* so/*view*) 34 | 35 | (def config 36 | "Configuration map. Indicates which namespaces should be used to shelf 37 | workspaces and recordings." 38 | (atom {:ws-ns '$ws 39 | :rec-ns '$rec})) 40 | 41 | (declare with-view) 42 | (declare ws-query*) 43 | (declare ws-query) 44 | (declare ws-print) 45 | (declare trees-print) 46 | 47 | ;; === Helper functions 48 | 49 | (defmacro src-in-meta 50 | "Takes a `body` form that evaluates to a var. Alters the var's meta 51 | to include the body source in :source. Useful for functions where 52 | source is not otherwise available -- ex eval'd outside the context of 53 | a file. 54 | 55 | Usage: 56 | 57 | user> (sd/src-in-meta defn f1 [a] (inc a)) 58 | {:arglists ([a]), :line 1, :column 1, :file \"/tmp/form-init5170899558834081664.clj\", :name f1, :ns #object[clojure.lang.Namespace 0x7d351966 \"user\"], :source (defn f1 [a] (inc a))} 59 | 60 | user> (-> #'f1 meta :source) 61 | (defn f1 [a] (inc a)) 62 | " 63 | [& body] 64 | `(util/src-in-meta ~@body)) 65 | 66 | ;; === Workspace functions 67 | 68 | (defn ws-init! [& [quiet]] 69 | (#'ws/init! workspace quiet)) 70 | 71 | (defn ws-get-active! 72 | "Returns the active workspace with atoms intact." 73 | [] 74 | @(ws-init! :quiet)) 75 | (util/defalias w-ga! ws-get-active!) 76 | 77 | (defn ws-show-traced* 78 | [& [ws]] 79 | (-> ws 80 | (or (ws-get-active!)) 81 | :traced)) 82 | 83 | (defn ws-show-traced 84 | "Pretty prints the map that contains the traces that are currently in 85 | place." 86 | [& [ws]] 87 | (-> ws 88 | ws-show-traced* 89 | clojure.pprint/pprint)) 90 | (util/defalias w-st ws-show-traced) 91 | 92 | (defn ws-remove-all-traces! 93 | "Disables and removes all traces in the active workspace." 94 | [] 95 | (#'ws/remove-all-traces! workspace) 96 | (ws-show-traced)) 97 | (util/defalias w-rat! ws-remove-all-traces!) 98 | 99 | (defn ws-remove-trace-fn! 100 | "Disables and removes a trace on a function from the active workspace." 101 | [fn-sym] 102 | (#'ws/remove-trace-fn! workspace fn-sym) 103 | (ws-show-traced)) 104 | (util/defalias w-rtf! ws-remove-trace-fn!) 105 | 106 | (defn ws-reset! 107 | "Removes all traces set by active workspace. Resets the active workspace to nil." 108 | [] 109 | (ws-remove-all-traces!) 110 | (#'ws/reset-to-nil! workspace)) 111 | (util/defalias w-rs! ws-reset!) 112 | 113 | (defn ws-clear-log! 114 | "Clears the log of the active workspace, but preserves traces and other 115 | properties." 116 | [] (#'ws/clear-log! (ws-init! :quiet))) 117 | (util/defalias w-cl! ws-clear-log!) 118 | 119 | (defn ws-add-trace-fn!* 120 | [fn-sym] 121 | (#'ws/add-trace-*! (ws-init! :quiet) 122 | :fn 123 | fn-sym) 124 | fn-sym) 125 | 126 | (defmacro ws-add-trace-fn! 127 | "`fn-sym` is a symbol that references an existing function. Applies an 128 | enabled trace to said functions. Adds the traces to the active 129 | workspace trace set." 130 | [fn-sym] 131 | `(ws-add-trace-fn!* (util/fully-qualify-sym '~fn-sym))) 132 | (util/defalias-macro w-atf! ws-add-trace-fn!) 133 | 134 | (defn ^:no-doc ws-add-inner-trace-fn!* 135 | [fn-sym] 136 | (#'ws/add-trace-*! (ws-init! :quiet) 137 | :inner-fn 138 | fn-sym) 139 | fn-sym) 140 | 141 | (defmacro ws-add-inner-trace-fn! 142 | "`fn-sym` is a symbol that references an existing function. Applies an 143 | enabled *inner* trace to said functions. Adds the traces to the active 144 | workspace trace set. Deep traces capture all functions calls that 145 | occurr within the traced function." 146 | [fn-sym] 147 | `(ws-add-inner-trace-fn!* (util/fully-qualify-sym ~(util/quote-if-sym fn-sym)))) 148 | 149 | (util/defalias-macro w-aitf! ws-add-inner-trace-fn!) 150 | 151 | (defn ^:no-doc ws-add-trace-ns!* 152 | "`ns-sym` is a symbol that references an existing namespace. Applies an enabled 153 | trace to all functions in that namespace. Adds the traces to the active workspace trace set." 154 | [ns-sym] 155 | (#'ws/add-trace-*! (ws-init! :quiet) 156 | :ns 157 | ns-sym) 158 | ns-sym) 159 | 160 | (defmacro ws-add-trace-ns! 161 | "`ns-sym` is a symbol that references an existing namespace. Applies an enabled 162 | trace to all functions in that namespace. Adds the traces to the active workspace trace set." 163 | [ns-sym] 164 | (let [ref-ns *ns*] 165 | `(mapv ws-add-trace-ns!* (find-ns/search-nses '~ns-sym ~ref-ns)))) 166 | (util/defalias-macro w-atn! ws-add-trace-ns!) 167 | 168 | (defmacro ws-remove-trace-ns! 169 | "`ns-sym` is a symbol that references an existing namespace. Removes all 170 | traces applied to the namespace." 171 | [ns-sym] 172 | (let [ref-ns *ns*] 173 | `(mapv (partial #'ws/remove-trace-*! 174 | (ws-init! :quiet) 175 | :ns) 176 | (find-ns/search-nses '~ns-sym ~ref-ns)))) 177 | (util/defalias-macro w-rtn! ws-remove-trace-ns!) 178 | 179 | (defn ws-enable-all-traces! 180 | "Enables any disabled traces in active workspace." 181 | [] (#'ws/enable-all-traces! workspace)) 182 | (util/defalias w-eat! ws-enable-all-traces!) 183 | 184 | (defn ws-enable-trace-fn! 185 | "Enables a trace on a function. Function must already have trace added 186 | to active workspace." 187 | [fn-sym] (#'ws/enable-trace-fn! workspace 188 | fn-sym)) 189 | (util/defalias w-etf! ws-enable-trace-fn!) 190 | 191 | (defn ws-enable-trace-ns! 192 | "Enables a trace on a namespace. Namespace must already have trace 193 | added to active workspace." 194 | [ns-sym] (#'ws/enable-all-traces! workspace 195 | #(= % ns-sym))) 196 | 197 | 198 | (defn ws-disable-trace-ns! 199 | "Enables a trace on a namespace. Namespace must already have trace 200 | added to active workspace." 201 | [ns-sym] (#'ws/disable-all-traces! workspace 202 | #(or (= % ns-sym) 203 | (-> % 204 | util/disqualify-sym 205 | first 206 | (= ns-sym))))) 207 | 208 | (defn ws-disable-all-traces! 209 | "Disables all traces in active workspace. The active workspace trace set will be 210 | preserved and can be re-enabled." 211 | [] (#'ws/disable-all-traces! workspace)) 212 | (util/defalias w-dat! ws-disable-all-traces!) 213 | 214 | (defn ws-disable-trace-fn! 215 | "Disables a trace on a function. The active workspace trace set will 216 | be preserved and can be re-enabled." 217 | [fn-sym] (#'ws/disable-trace-fn! workspace fn-sym)) 218 | (util/defalias w-dtf! ws-disable-trace-fn!) 219 | 220 | (defn ws-cycle-all-traces! 221 | "Disables and enables all traces in active workspace. You shouldn't 222 | need to use this, but you might." 223 | [] 224 | (ws-disable-all-traces!) 225 | (ws-enable-all-traces!)) 226 | (util/defalias w-cat! ws-cycle-all-traces!) 227 | 228 | (defn ws-deref! 229 | "Returns the value of the active workspace, but with all children 230 | recursively dereferenced. This workspace value will not receive new 231 | trace entries." 232 | [& [w]] (#'ws/deep-deref! (or w 233 | workspace))) 234 | (util/defalias w-drf! ws-deref!) 235 | 236 | (defn ws-view! 237 | [& [w]] 238 | (let [w' (or w 239 | (ws-deref!))] 240 | (q/q w' [*view*]))) 241 | (util/defalias w-v! ws-view!) 242 | 243 | (defn ws-save! 244 | "Saves active workspace to the workspace shelf namespace in the pre-specified slot." 245 | [] 246 | (#'ws/save! workspace (:ws-ns @config))) 247 | (util/defalias w-s! ws-save!) 248 | 249 | (defn ws-save-as! 250 | "Saves active workspace to the workspace shelf namespace in the specified `slot`." 251 | [slot] 252 | (#'ws/save-as! workspace 253 | (:ws-ns @config) 254 | slot) 255 | true) 256 | (util/defalias w-sa! ws-save-as!) 257 | 258 | (defn ws-load! 259 | "Loads a workspace from the shelf namespace into the active 260 | position. Will not overwrite an un-saved active workspace unless 261 | `force` equals :f" 262 | [slot & [force]] 263 | (#'ws/load! workspace 264 | (:ws-ns @config) 265 | slot 266 | force) 267 | true) 268 | (util/defalias w-l! ws-load!) 269 | 270 | (defn ^:no-doc inner-trace-apply* 271 | [workspace qual-sym args] 272 | (let [meta' (-> qual-sym 273 | resolve 274 | meta) 275 | ns' (-> meta' 276 | :ns 277 | str) 278 | itraced-fn (itrace/inner-tracer {:workspace nil 279 | :qual-sym qual-sym 280 | :meta' meta' 281 | :ns' ns'} 282 | nil)] 283 | (binding [trace/*trace-log-parent* workspace] 284 | (apply itraced-fn args)))) 285 | 286 | (defn ws-inner-trace-apply 287 | "Deep traces the function indicated by the qualified symbol, 288 | `qual-sym`, and then call it with arguments `args`. Returns the 289 | resulting workspace, which is NOT the active workspace." 290 | [qual-sym args] 291 | (let [workspace (ws/default-workspace)] 292 | (inner-trace-apply* workspace 293 | qual-sym 294 | args) 295 | (ws-deref! workspace))) 296 | (util/defalias w-dta ws-inner-trace-apply) 297 | 298 | (defn ws-inner-trace-apply-print 299 | "Run `ws-inner-trace-apply` then prints the resulting workspace." 300 | [qual-sym args] 301 | (ws-print (ws-inner-trace-apply qual-sym 302 | args))) 303 | (util/defalias w-itap ws-inner-trace-apply-print) 304 | 305 | 306 | ;; === END Workspace functions 307 | 308 | ;; === Recording functions 309 | 310 | (defn rec-reset! 311 | "Removes all traces set by active workspace. Resets the active workspace to nil." 312 | [] 313 | (#'rec/reset-to-nil! recording)) 314 | (util/defalias r-rst! rec-reset!) 315 | 316 | (defn rec-save! 317 | "Saves active recording to the recording shelf namespace in the pre-specified slot." 318 | [] 319 | (#'rec/save! recording (:rec-ns @config)) 320 | true) 321 | (util/defalias r-s! rec-save!) 322 | 323 | (defn rec-save-as! 324 | "Saves active recording to the recording shelf namespace in the specified `slot`." 325 | [slot] 326 | (->> (#'rec/save-as! recording 327 | (:rec-ns @config) 328 | slot) 329 | ((juxt :id :rec-slot)) 330 | (apply format "Saved recording with id '%s' to slot '%s'."))) 331 | (util/defalias r-sa! rec-save-as!) 332 | 333 | (defn rec-load! 334 | "Loads a recording from the shelf namespace into the active 335 | position. Will not overwrite an un-saved active recording unless 336 | `active` equals :f" 337 | [slot & [force]] 338 | (#'rec/load! recording 339 | (:rec-ns @config) 340 | slot 341 | force)) 342 | (util/defalias r-l! rec-load!) 343 | 344 | (defn rec-load-from! 345 | "Loads a recording from the provided source. Source may be a workspace" 346 | [src & [force]] 347 | (->> (#'rec/coerce&load! recording 348 | src 349 | (:rec-ns @config) 350 | force) 351 | ((juxt :id :rec-slot)) 352 | (apply format "Loaded recording with id '%s', slot '%s' to active position."))) 353 | (util/defalias r-lf! rec-load-from!) 354 | 355 | (defn rec-load-from-ws! 356 | "Loads the active workspace into the active record." 357 | [& [force]] 358 | (rec-load-from! (ws-get-active!) force) 359 | true) 360 | (util/defalias r-lfw! rec-load-from-ws!) 361 | 362 | ;; === END Recording functions 363 | 364 | 365 | ;; === String Output functions 366 | 367 | (def tree->string #'so/tree->string) 368 | 369 | (defn- get-trees 370 | [v] 371 | (let [mk (meta v)] 372 | (cond 373 | (sequential? v) 374 | v 375 | 376 | ((some-fn :trace-root 377 | ::ws/workspace 378 | ::rec/recording 379 | ::q/query-result) 380 | mk) 381 | (:children v) 382 | 383 | (::trace/tree mk) 384 | [v] 385 | 386 | (every? #(contains? v %) 387 | [:children :depth :args :name :return :arg-map :id]) 388 | [v] 389 | 390 | :default 391 | (throw (Exception. (format "Don't know how to get a tree from this thing. keys=> %s, meta=> %s" 392 | (keys v) 393 | (meta v))))))) 394 | 395 | (defmacro with-this-view 396 | ([view' & body] 397 | `(let [v# (or ~view' 398 | so/*view*)] 399 | (binding [*view* v# 400 | so/*view* v#] 401 | ~@body)))) 402 | 403 | (defmacro with-view 404 | "Puts the view in effect for the lexical scope." 405 | ([& body] 406 | `(with-this-view @view ~@body))) 407 | 408 | (defn trees-print 409 | "Prints `trees`, which may be either trace tree, a collection of trace 410 | trees, or a known structure (workspace, recording) that contains a trace tree." 411 | [trees] 412 | (-> trees 413 | get-trees 414 | (#'so/print-trees))) 415 | (util/defalias t-pr trees-print) 416 | 417 | (defn ws-print 418 | "Prints either the active workspace, or the first argument, using the 419 | default view, which puts safety restrictions on the output to 420 | prevent overwhelming hugeness." 421 | [& [ws]] 422 | (with-view (-> ws 423 | ws-view! 424 | (#'so/print-tree)))) 425 | (util/defalias w-pr ws-print) 426 | 427 | (defn rec-print 428 | [& [rec]] 429 | (#'so/print-tree (or rec 430 | @recording))) 431 | (util/defalias r-pr rec-print) 432 | 433 | (defn set-view! 434 | [& [view']] 435 | (reset! view view')) 436 | 437 | ;; === END String Output functions 438 | 439 | 440 | ;; === Query functions 441 | 442 | (def query-docs 443 | "There are several querying functions. Many of them take a variadic 444 | `body` argument. The syntax of the `body` argument is described 445 | below: 446 | 447 | Body may or may not begin with a keyword. If it doesn't, body is one 448 | or more vectors which specify a query. 449 | 450 | If it does being with a keyword, the syntax rules of that keyword 451 | apply to the args that follow. The keyword acts as a modifier that 452 | expands the query results to include nodes that have a specified type 453 | of relationship with any nodes matching the query. The modifiers are 454 | listed here: 455 | 456 | :a -- returns ancestors of matching nodes 457 | :d -- returns descendants of matching nodes 458 | :s -- returns siblings of matching nodes 459 | :w -- wildcard! returns ancestors, descendants and siblings of matching nodes 460 | :r -- range; takes exactly two query vectors and returns nodes that 461 | are both descendants of the first and ancestors of the second 462 | 463 | Additionally, the keywords :a, :d, :s and :w take an optional numeric 464 | argument which precedes the vector queries. This number specifies a 465 | limit on the number of relative hops that will be taken. 466 | 467 | A query clause may be a vector or a symbol. A vector is applied in a 468 | `get-in` fashion to each trace node, with the final element acting as 469 | a matching value or predicate function. If the final value is truthy, 470 | the node is included in the query result set. For example, a `body` of 471 | 472 | :a 2 [:arg-map 'fruit :apple] 473 | 474 | would match any trace node where an argument `fruit` took a 475 | value :apple, as well as the parent and grandparent of that node. 476 | 477 | If the query is a symbol instead of a vector, the query will match any 478 | node whose function name matches the symbol. For example, a `body` of 479 | 480 | somefunc 481 | 482 | is equivalent to: [:name 'somefunc] 483 | " 484 | nil) 485 | 486 | (defmacro query-by-name 487 | "Produces a vector like [:name 'func] for `s` equal to 'func. Just a 488 | little shortcut for when querying by a function name." 489 | [s] 490 | `[:name '~(util/fully-qualify-sym s)]) 491 | (util/defalias-macro qbn query-by-name) 492 | 493 | (defn- syms->qbn 494 | [form] 495 | (map #(if (symbol? %) 496 | `(qbn ~%) 497 | %) 498 | form)) 499 | 500 | (defn ws-query* 501 | [& query] 502 | (apply #'q/q 503 | (ws-view!) 504 | query)) 505 | 506 | (defmacro ws-query 507 | "Queries the trace record of the active workspace." 508 | [& body] `(ws-query* ~@(syms->qbn body))) 509 | (util/defalias-macro w-q ws-query) 510 | 511 | (defmacro ws-query-print 512 | "Queries the trace record of the active workspace and prints the results." 513 | [& body] 514 | `(with-view 515 | (trees-print (ws-query ~@body)))) 516 | (util/defalias-macro w-qp ws-query-print) 517 | (util/defalias-macro q ws-query-print) 518 | 519 | (defmacro rec-query 520 | "Queries the active trace recording." 521 | [& body] `(q/q @recording 522 | ~@body)) 523 | (util/defalias-macro r-q rec-query) 524 | 525 | (defmacro tree-query 526 | "Queries `tree`, a trace tree." 527 | [tree & body] `(q/q ~tree 528 | ~@body)) 529 | (util/defalias-macro t-query tree-query) 530 | 531 | ;; === END Query functions 532 | 533 | ;; === Profiling functions 534 | 535 | (defn pro-analyze 536 | "Takes a tree (workspace, recording, query result) and assocs profile 537 | data to it at :profile." 538 | [tree] 539 | (#'pro/assoc-tree-with-profile tree)) 540 | (util/defalias p-a pro-analyze) 541 | 542 | (defn pro-net-time 543 | "Takes a tree with profilings data (see `pro-analyze`) and prints a 544 | table of functions and their profile metrics, sorted by net time 545 | sum. 'Net time sum' is the amount of time spent in a function minus 546 | the time spent executing its children. Functions with high net time 547 | sum may be candidates for optimization." 548 | [tree] 549 | (->> tree 550 | :profile 551 | (map (fn [[k v]] 552 | (assoc v 553 | :name k))) 554 | (sort-by :net-time-sum) 555 | (clojure.pprint/print-table [:name :net-time-sum 556 | :net-time-avg :count 557 | :gross-time-sum :gross-time-avg]))) 558 | (util/defalias p-nt pro-net-time) 559 | 560 | 561 | (defn pro-gross-repeats 562 | "Takes a tree with profilings data (see `pro-analyze`) and prints a 563 | table of functions and their profile metrics, sorted by gross time of 564 | repeated arguments. 'Gross of repeats' is the amount of time spent in 565 | a function during calls where the args match those of a previous call 566 | to the function. Functions with high gross of repeats may be 567 | candidates for memoization." 568 | [tree] 569 | (->> tree 570 | :profile 571 | (map (fn [[k v]] 572 | (assoc v 573 | :name k))) 574 | (sort-by :gross-of-repeats) 575 | (clojure.pprint/print-table [:name :gross-of-repeats 576 | :count :arg-cardinality 577 | :repeat-arg-pct 578 | :gross-time-sum :gross-time-avg]))) 579 | (util/defalias p-gr pro-gross-repeats) 580 | 581 | ;; === END Profiling functions 582 | 583 | 584 | ;; === TEMP 585 | 586 | (defn mk-src-pos-query-fn 587 | [file line] 588 | (fn [{:keys [src-pos]}] 589 | (and (= (:file src-pos) file) 590 | (<= (:line src-pos) line) 591 | (>= (:end-line src-pos) line)))) 592 | 593 | (defn ws-query-by-file-line 594 | [file line] 595 | (println) 596 | (trees-print (ws-query* [(mk-src-pos-query-fn file line)])) 597 | (println)) 598 | 599 | ;; used only by middleware 600 | (defn ws-query-by-file-pos 601 | [file line] 602 | (ws-query* [:id (q/get-ids-from-file-pos (ws-view!) 603 | file 604 | line)])) 605 | -------------------------------------------------------------------------------- /src/com/billpiel/sayid/string_output2.clj: -------------------------------------------------------------------------------- 1 | (ns com.billpiel.sayid.string-output2 2 | (:require [com.billpiel.sayid.workspace :as ws] 3 | [com.billpiel.sayid.view :as v] 4 | [com.billpiel.sayid.util.other :as util] 5 | [tamarin.core :as tam] 6 | [clojure.zip :as z] 7 | clojure.string)) 8 | 9 | (def ^:dynamic *view* (fn [x] {:args true 10 | :return true 11 | :throw true 12 | :selects false})) 13 | 14 | (def ^:dynamic *color-palette* [1 3 2 6 5]) 15 | 16 | (def colors-kw [:black :red :green :yellow :blue :magenta :cyan :white]) 17 | 18 | (defn apply-color-palette 19 | [n] 20 | (when n 21 | (nth *color-palette* 22 | (mod n (count *color-palette*))))) 23 | 24 | (def line-break-token {:string "\n" :length 1 :line-break true}) 25 | 26 | (defn render-tkns 27 | [v] 28 | (if (-> v meta ::util/recur) 29 | (tam/render-tokens (apply list 'recur v)) 30 | (tam/render-tokens v))) 31 | 32 | (defn tkn 33 | [s & {:keys [fg fg* bg bg* bold] :as props}] 34 | (if (= s "\n") 35 | line-break-token 36 | (let [s' (cond (string? s) s 37 | (sequential? s) (apply str s) 38 | :else (pr-str s))] 39 | (-> props 40 | (dissoc :fg :bg :bg* :bold) 41 | (assoc 42 | :string s' 43 | :length (count s') 44 | :color [(get colors-kw (or fg (apply-color-palette fg*))) 45 | (get colors-kw (or bg (apply-color-palette bg*)))] 46 | :bold bold))))) 47 | 48 | (defn mk-lazy-color-fg*-str 49 | ([s] (mk-lazy-color-fg*-str s 0)) 50 | ([s i] (lazy-cat [(tkn s :fg* i)] 51 | (mk-lazy-color-fg*-str s (inc i))))) 52 | 53 | (def lazy-color-fg*-pipes (mk-lazy-color-fg*-str "|")) 54 | 55 | (defn slinky-pipes 56 | [len & {:keys [end]}] 57 | (concat 58 | (take (- len (count end)) lazy-color-fg*-pipes) 59 | (if end 60 | [(tkn end :fg* (dec len))] 61 | []) 62 | [(tkn " ")])) 63 | 64 | (def slinky-pipes-MZ (memoize slinky-pipes)) 65 | 66 | (defn indent 67 | [depth & {:keys [end]}] 68 | (slinky-pipes-MZ depth 69 | :end end)) 70 | 71 | (defn breaker 72 | [f coll] 73 | (let [[head [delim & tail]] (split-with (complement f) 74 | coll)] 75 | (lazy-cat [head] (if (not-empty tail) 76 | (breaker f tail) 77 | [])))) 78 | 79 | (defn get-line-length 80 | [line] 81 | (->> line (map :length) (apply +))) 82 | 83 | (defn buffer-lines-to-width 84 | [width column] 85 | (map (fn [line] 86 | (let [buf-length (->> line (map :length) (apply +) (- width))] 87 | (if (> buf-length 0) 88 | (conj (vec line) {:string (apply str (repeat buf-length " ")) 89 | :length buf-length}) 90 | line))) 91 | column)) 92 | 93 | (defn mk-column-str 94 | [indent & cols] 95 | (def i' indent) 96 | (def c' cols) 97 | (let [lines (map (partial breaker :line-break) cols) 98 | max-height (->> lines 99 | (map count) 100 | (apply max)) 101 | lines' (map #(take max-height (concat % (repeat []))) lines) 102 | widths (map #(->> % 103 | (map get-line-length) 104 | (apply max) 105 | inc) 106 | lines)] 107 | (apply concat 108 | (apply interleave 109 | indent 110 | (conj (mapv buffer-lines-to-width 111 | widths 112 | lines') 113 | (repeat [(tkn "\n")])))))) 114 | 115 | (defn multi-line-indent2 116 | [& {:keys [cols indent-base]}] 117 | (->> cols 118 | (apply mk-column-str 119 | (repeat (indent indent-base))))) 120 | 121 | (def multi-line-indent2-MZ (memoize multi-line-indent2)) 122 | 123 | (defn get-line-meta 124 | [v & {:keys [path header?]}] 125 | (util/$- some-> (or (:src-pos v) 126 | (:meta v)) 127 | (select-keys [:line :column :file :end-line :end-column]) 128 | (clojure.set/rename-keys {:line :src-line 129 | :column :src-column 130 | :file :src-file 131 | :end-line :src-end-line 132 | :end-column :src-end-column}) 133 | (assoc :id (:id v) 134 | :fn-name (or (:parent-name v) 135 | (:name v)) 136 | :path path 137 | :header header?) 138 | (update-in [:file] #(if (string? %) 139 | (util/get-src-file-path %) 140 | %)) 141 | (assoc $ 142 | :line-meta? true))) 143 | 144 | (defn indent-arg-map 145 | [tree m] 146 | (->> m 147 | (map (fn [[label value]] 148 | [(get-line-meta tree 149 | :path [:arg-map label]) 150 | (multi-line-indent2 :cols [[(tkn [label " =>"])] (render-tkns value)] 151 | :indent-base (:depth tree))])) 152 | vec)) 153 | 154 | (defn indent-map 155 | [tree m] 156 | (->> m 157 | (map (fn [[label value]] 158 | (multi-line-indent2 :cols [[(tkn [label " =>"])] (render-tkns value)] 159 | :indent-base (:depth tree) 160 | :indent-offset 3))) 161 | vec)) 162 | 163 | (defn selects-str 164 | [tree selects] 165 | (let [sel-fn (fn [sel] 166 | (util/get-some (if (vector? sel) 167 | sel 168 | [sel]) 169 | tree)) 170 | sel-map (util/apply-to-map-vals sel-fn 171 | selects)] 172 | [(get-line-meta tree) 173 | (indent-map tree sel-map)])) 174 | 175 | (defn throw-str 176 | [tree] 177 | (when-let [thrown (:throw tree)] 178 | [(get-line-meta tree 179 | :path [:throw]) 180 | (multi-line-indent2 :cols [[(tkn "THROW" :fg 1 :bg 7) 181 | (tkn " => ")] 182 | (render-tkns thrown)] 183 | :indent-base (:depth tree))])) 184 | 185 | (defn return-str 186 | [tree & {pos :pos}] 187 | (when (contains? tree :return) 188 | (let [return (:return tree)] 189 | [(get-line-meta tree 190 | :path [:return]) 191 | (multi-line-indent2 :cols [[(tkn [(condp = pos 192 | :before "returns" 193 | :after "returned") 194 | " => "])] 195 | (render-tkns return)] 196 | :indent-base (:depth tree))]))) 197 | 198 | (defn args-map-str 199 | [tree] 200 | (when-let [arg-map (:arg-map tree)] 201 | (indent-arg-map tree arg-map))) 202 | 203 | (defn args-str 204 | [tree] 205 | (when-let [args (:args tree)] 206 | (->> args 207 | (map-indexed (fn [i value] 208 | [(get-line-meta tree :path [:args i]) 209 | (multi-line-indent2 :cols [(render-tkns value)] 210 | :indent-base (:depth tree))])) 211 | vec))) 212 | 213 | (defn let-binds-str 214 | [tree] 215 | (->> tree 216 | :let-binds 217 | (map-indexed (fn [i [val sym frm]] 218 | [(get-line-meta tree :path [:let-binds i 0]) 219 | (multi-line-indent2 :cols [[(tkn sym) 220 | (tkn " <= ")] 221 | (render-tkns val) 222 | [(tkn " <= ")] 223 | (render-tkns frm)] 224 | :indent-base (:depth tree))])) 225 | vec)) 226 | 227 | (defn args*-str 228 | [tree] 229 | (let [test #(-> tree % not-empty)] 230 | ((cond 231 | (test :arg-map) args-map-str 232 | (test :args) args-str 233 | (test :let-binds) let-binds-str 234 | :else (constantly (tkn ""))) 235 | tree))) 236 | 237 | (defn name->string 238 | [tree start?] 239 | (let [{:keys [depth name form ns parent-name macro? xpanded-frm]} tree] 240 | (if (nil? depth) 241 | [] 242 | [(get-line-meta tree :header? true) 243 | (slinky-pipes-MZ depth :end (when start? "v")) 244 | (when (:throw tree) 245 | [(tkn "!" :fg 1 :bg 7) (tkn " ")]) 246 | (if parent-name 247 | [(tkn (if-not (nil? form) 248 | [form] 249 | name) 250 | :fg 0 :bg* (dec depth) :bold false) 251 | (when macro? 252 | (tkn [" => " (str xpanded-frm)] 253 | :fg* (dec depth) :bg 0 :bold false)) 254 | (tkn [" " (str parent-name)] 255 | :fg* (dec depth) :bg 0 :bold false)] 256 | (tkn name :fg* (dec depth) :bg 0 :bold false)) 257 | (tkn " ") 258 | (tkn (-> tree :id str) 259 | :fg 7)]))) 260 | 261 | (defmacro when-sel 262 | [kw & body] 263 | `(when (~kw ~'view) 264 | [~@body])) 265 | 266 | (defn tree->string* 267 | [tree] 268 | (if (nil? tree) 269 | [] 270 | (let [view (*view* tree) 271 | trace-root? (-> tree meta :trace-root) 272 | visible? (and (not trace-root?) 273 | view) 274 | has-children (some-> tree 275 | :children 276 | not-empty)] 277 | [(when visible? 278 | [(name->string tree true) (tkn "\n") 279 | (when-let [selects (:selects view)] 280 | (selects-str tree selects)) 281 | (when-sel :args (args*-str tree))]) 282 | (when has-children 283 | [(when-sel :return (return-str tree :pos :before)) 284 | (when-sel :throw (throw-str tree)) 285 | (mapv tree->string* (:children tree)) 286 | (when (not trace-root?) 287 | [(name->string tree false) (tkn "\n")]) 288 | (when-sel :args 289 | (args*-str tree))]) 290 | (when visible? 291 | [(when-sel :return (return-str tree :pos :after)) 292 | (when-sel :throw (throw-str tree)) 293 | (get-line-meta tree) ;; clear meta 294 | (slinky-pipes-MZ (:depth tree) 295 | :end "^")]) 296 | (tkn "\n")]))) 297 | 298 | (defn increment-position 299 | [line-break? line column pos] 300 | (if line-break? 301 | [(inc line) 0 pos] 302 | [line column pos])) 303 | 304 | (defn assoc-tokens-pos 305 | [tokens] 306 | (loop [[{:keys [length line-break line-meta?] :as head} & tail] tokens 307 | line-meta nil 308 | pos 0 309 | line 0 310 | col 0 311 | agg []] 312 | (cond (nil? head) agg 313 | line-meta? (recur tail head pos line col agg) 314 | :else (let [end-pos (+ pos length) 315 | end-col (+ pos col) 316 | [line' col' pos'] (increment-position line-break line end-col end-pos)] 317 | (recur tail 318 | line-meta 319 | pos' 320 | line' 321 | col' 322 | (util/$- -> head 323 | (merge line-meta) 324 | (assoc :line line 325 | :start-col col 326 | :end-col end-col 327 | :start pos 328 | :end end-pos) 329 | (conj agg $))))))) 330 | 331 | (defn remove-nil-vals 332 | [m] 333 | (for [[k v] m :when (not (nil? v))] [k v])) 334 | 335 | (defn tkn->simple-type 336 | [t] 337 | (-> t :type first)) 338 | 339 | (def ^:const type->color {:int :cyan 340 | :float :cyan 341 | :string :magenta 342 | :keyword :yellow 343 | :symbol :cyan 344 | :truncator :black}) 345 | 346 | (def ^:const type->bg-color {:truncator :white}) 347 | 348 | (defn apply-type-colors-to-token 349 | [{[fg-color bg-color] :color :as token}] 350 | (let [st (tkn->simple-type token)] 351 | (assoc token 352 | :color [(or (type->color st) fg-color) 353 | (or (type->bg-color st) bg-color)]))) 354 | 355 | (defn mk-text-props 356 | [{:keys [start end] :as token}] 357 | (util/$- -> token 358 | (dissoc :coll? 359 | :column 360 | :start 361 | :end 362 | :end-col 363 | :end-column 364 | :end-line 365 | :length 366 | :line 367 | :line-meta? 368 | :line-break 369 | :string 370 | :zipper) 371 | apply-type-colors-to-token 372 | remove-nil-vals 373 | [start end $])) 374 | 375 | 376 | (defn tkn-prop-grouper4 377 | [pos-pairs start end] 378 | (if (empty? pos-pairs) {:last-start start :last-end end :pairs []} 379 | (let [{:keys [last-start last-end pairs]} pos-pairs] 380 | (if (= last-end start) 381 | (assoc pos-pairs :last-end end) 382 | (assoc pos-pairs 383 | :last-start start 384 | :last-end end 385 | :pairs (conj pairs [last-start last-end])))))) 386 | 387 | (defn tkn-prop-grouper3 388 | [start end] 389 | (fn [agg pos-pairs] 390 | (update-in agg pos-pairs tkn-prop-grouper4 start end))) 391 | 392 | (defn tkn-prop-grouper2 393 | [agg [start end props]] 394 | (reduce (tkn-prop-grouper3 start end) 395 | agg 396 | props)) 397 | 398 | (defn tkn-prop-grouper6 399 | [pairs] 400 | (reduce (fn [agg [start end]] 401 | (update-in agg 402 | [(- end start)] 403 | conj start)) 404 | {} 405 | pairs)) 406 | 407 | (defn tkn-prop-grouper5 408 | [m] 409 | (reduce (fn [agg [a b c]] 410 | (if b 411 | (assoc-in agg 412 | [a b] 413 | (tkn-prop-grouper6 c)) 414 | agg)) 415 | {} 416 | (for [[k kv] m 417 | [k2 {:keys [last-end last-start pairs]}] kv] 418 | [k k2 (conj pairs [last-start last-end]) ]))) 419 | 420 | (defn tkn-prop-grouper 421 | [triples] 422 | (tkn-prop-grouper5 (reduce tkn-prop-grouper2 423 | {} 424 | triples))) 425 | 426 | (defn split-text-tag-coll 427 | [tokens] 428 | [(->> tokens (map :string) (apply str)) 429 | (->> tokens 430 | assoc-tokens-pos 431 | (mapv mk-text-props) 432 | tkn-prop-grouper)]) 433 | 434 | (defn tree->text-prop-pair 435 | [tree] 436 | (->> tree 437 | tree->string* 438 | flatten 439 | (remove nil?) 440 | split-text-tag-coll)) 441 | 442 | (defn audit-ns->summary-view 443 | [audit-ns] 444 | (let [[ns-sym audit-fns] audit-ns 445 | fn-count (count audit-fns) 446 | traced-count (->> audit-fns 447 | (map second) 448 | (map :trace-type) 449 | (filter #{:fn :inner-fn}) 450 | count)] 451 | (tkn (format " %s / %s %s\n" traced-count fn-count ns-sym) 452 | :ns ns-sym))) 453 | 454 | (defn audit-fn->view 455 | [[ fn-sym {:keys [trace-type trace-selection] :as fn-meta}]] 456 | (apply tkn (format " %s %s %s\n" 457 | (case trace-selection 458 | :fn "O" 459 | :inner-fn "I" 460 | :ns " " 461 | nil "x" 462 | :else "?") 463 | (case trace-type 464 | :fn "E" 465 | :inner-fn "E" 466 | nil "D" 467 | :else "?") 468 | fn-sym) 469 | (apply concat fn-meta))) 470 | 471 | (defn audit-fn-group->view 472 | [[ns-sym audit-fns]] 473 | (concat [(tkn (format "- in ns %s\n" ns-sym))] 474 | (map audit-fn->view audit-fns))) 475 | 476 | (defn audit->top-view 477 | [audit] 478 | (concat [(tkn "Traced namespaces:\n")] 479 | (map audit-ns->summary-view (:ns audit)) 480 | [(tkn "\n\nTraced functions:\n")] 481 | (map audit-fn-group->view (:fn audit)))) 482 | 483 | (defn audit->ns-view 484 | [audit & [ns-sym]] 485 | (concat [(tkn (format "Namespace %s\n" ns-sym) :ns ns-sym)] 486 | (map audit-fn->view 487 | (-> audit :ns (get ns-sym))) 488 | [(tkn "\n\nTraced functions:\n")] 489 | (map audit-fn->view 490 | (-> audit :fn (get ns-sym))))) 491 | 492 | 493 | 494 | 495 | (defn tree->string [tree] 496 | (->> tree 497 | tree->text-prop-pair 498 | first 499 | (apply str))) 500 | 501 | (defn print-tree [tree] 502 | (->> tree 503 | tree->text-prop-pair 504 | first 505 | (apply str) 506 | println)) 507 | 508 | (defn print-trees 509 | [trees] 510 | (doseq [t trees] 511 | (print-tree t))) 512 | 513 | (defn ansi-color-code 514 | ([] (ansi-color-code {})) 515 | ([{:keys [fg-color bg-color]}] 516 | (let [fg (.indexOf colors-kw (or fg-color :white)) 517 | bg (.indexOf colors-kw (or bg-color :black))] 518 | (->> [(if (= fg -1) nil (+ 30 fg)) 519 | (if (= bg -1) nil (+ 40 bg))] 520 | (remove nil?) 521 | not-empty 522 | (clojure.string/join ";") 523 | (format "\33[%sm"))))) 524 | 525 | (defn print-tree-ansi [tree] 526 | (->> tree 527 | tree->string* 528 | flatten 529 | (remove nil?) 530 | (map apply-type-colors-to-token) 531 | (mapcat (fn [t][(ansi-color-code t) 532 | (:string t) 533 | (ansi-color-code)])) 534 | (apply str) 535 | print)) 536 | 537 | (defn print-trees-ansi 538 | [trees] 539 | (doseq [t trees] 540 | (print-tree t))) 541 | 542 | (defn value->text-prop-pair 543 | [a] 544 | (->> a 545 | render-tkns 546 | flatten 547 | (remove nil?) 548 | split-text-tag-coll)) 549 | 550 | (defn adjusted-pos 551 | [n] 552 | (let [n' (or (some-> n :bounds first) n) 553 | {:keys [start start-line]} n'] 554 | (when (and start start-line) 555 | (-> start 556 | inc)))) 557 | 558 | (defn find-up-node 559 | [z] 560 | (let [up (some-> z z/up z/node)] 561 | (if (= (tkn->simple-type up) :map-entry) 562 | (some-> z z/up z/up z/node) 563 | up))) 564 | 565 | (defn find-out-node 566 | [z] 567 | (let [up (some-> z z/up z/node)] 568 | (if (= (tkn->simple-type up) :map-entry) 569 | (some-> z z/up z/up z/node) 570 | up))) 571 | 572 | (defn find-in-node 573 | [z] 574 | (let [down (some-> z z/down z/node)] 575 | (if (= (tkn->simple-type down) :map-entry) 576 | (some-> z z/down z/down z/right z/node) 577 | down))) 578 | 579 | (defn find-prev-node 580 | [z] 581 | (let [up (some-> z z/up z/node)] 582 | (if (= (tkn->simple-type up) :map-entry) 583 | (some-> z z/up z/left z/down z/right z/node) 584 | (some-> z z/left z/node)))) 585 | 586 | (defn find-next-node 587 | [z] 588 | (let [up (some-> z z/up z/node)] 589 | (if (= (tkn->simple-type up) :map-entry) 590 | (some-> z z/up z/right z/down z/right z/node) 591 | (some-> z z/right z/node)))) 592 | 593 | 594 | (declare get-path) 595 | 596 | (defn update-last 597 | [coll f] 598 | (update-in coll 599 | [(-> coll count dec)] 600 | f)) 601 | 602 | (defn get-path-of-vec-child 603 | [z] 604 | (if-let [left (z/left z)] 605 | (update-last (get-path left) inc) 606 | (conj (-> z z/up get-path) 0))) 607 | 608 | (defn get-path 609 | [z] 610 | (if-let [up (z/up z)] 611 | (let [parent (z/node up)] 612 | (case (-> parent :type first) 613 | :map (get-path up) 614 | :record (get-path up) 615 | :map-entry (conj (get-path up) (some-> up z/down z/node :string)) 616 | :vector (get-path-of-vec-child z) 617 | :list (get-path-of-vec-child z) 618 | :listp (get-path-of-vec-child z) 619 | :seq (get-path-of-vec-child z) 620 | :set (get-path-of-vec-child z))) 621 | [])) 622 | 623 | (defn decorate-token 624 | [t] 625 | (let [z (:zipper t) 626 | out (adjusted-pos (find-out-node z)) 627 | in (adjusted-pos (find-in-node z)) 628 | prev (adjusted-pos (find-prev-node z)) 629 | next (adjusted-pos (find-next-node z))] 630 | (if (or out in prev next) 631 | (-> t 632 | (assoc :neighbors [out in prev next]) 633 | (assoc :path (util/$- some-> t 634 | :zipper 635 | get-path 636 | (clojure.string/join " " $)))) 637 | t))) 638 | 639 | (defn split-text-tag-coll* 640 | [tokens] 641 | [(->> tokens (map :string) (apply str)) 642 | (->> tokens 643 | (mapv mk-text-props) 644 | (remove #(or (nil? (first %)) (nil? (second %)))) 645 | tkn-prop-grouper)]) 646 | 647 | (defn value->text-prop-pair* 648 | [a] 649 | (->> a 650 | render-tkns 651 | flatten 652 | (remove nil?) 653 | (map decorate-token) 654 | split-text-tag-coll*)) 655 | 656 | (defn tokens->text-prop-pair 657 | [tokens] 658 | (->> tokens 659 | flatten 660 | (remove nil?) 661 | split-text-tag-coll)) 662 | --------------------------------------------------------------------------------