clone url: git://git.m455.casa/fa
esperbuild/espersrc/fennel-0.7.0/fennelview.fnl
| 1 | ;; A pretty-printer that outputs tables in Fennel syntax. |
| 2 | ;; Loosely based on inspect.lua: http://github.com/kikito/inspect.lua |
| 3 | |
| 4 | (fn view-quote [str] (.. "\"" (: str :gsub "\"" "\\\"") "\"")) |
| 5 | |
| 6 | (local short-control-char-escapes |
| 7 | {"\a" "\\a" "\b" "\\b" "\f" "\\f" "\n" "\\n" |
| 8 | "\r" "\\r" "\t" "\\t" "\v" "\\v"}) |
| 9 | |
| 10 | (local long-control-char-escapes |
| 11 | (let [long {}] |
| 12 | (for [i 0 31] |
| 13 | (let [ch (string.char i)] |
| 14 | (when (not (. short-control-char-escapes ch)) |
| 15 | (tset short-control-char-escapes ch (.. "\\" i)) |
| 16 | (tset long ch (: "\\%03d" :format i))))) |
| 17 | long)) |
| 18 | |
| 19 | (fn escape [str] |
| 20 | (-> str |
| 21 | (: :gsub "\\" "\\\\") |
| 22 | (: :gsub "(%c)%f[0-9]" long-control-char-escapes) |
| 23 | (: :gsub "%c" short-control-char-escapes))) |
| 24 | |
| 25 | (fn sequence-key? [k len] |
| 26 | (and (= (type k) "number") |
| 27 | (<= 1 k) |
| 28 | (<= k len) |
| 29 | (= (math.floor k) k))) |
| 30 | |
| 31 | (local type-order {:number 1 :boolean 2 :string 3 :table 4 |
| 32 | :function 5 :userdata 6 :thread 7}) |
| 33 | |
| 34 | (fn sort-keys [a b] |
| 35 | (let [ta (type a) tb (type b)] |
| 36 | (if (and (= ta tb) |
| 37 | (or (= ta "string") (= ta "number"))) |
| 38 | (< a b) |
| 39 | (let [dta (. type-order a) |
| 40 | dtb (. type-order b)] |
| 41 | (if (and dta dtb) |
| 42 | (< dta dtb) |
| 43 | dta true |
| 44 | dtb false |
| 45 | :else (< ta tb)))))) |
| 46 | |
| 47 | (fn get-sequence-length [t] |
| 48 | (var len 1) |
| 49 | (each [i (ipairs t)] (set len i)) |
| 50 | len) |
| 51 | |
| 52 | (fn get-nonsequential-keys [t] |
| 53 | (let [keys {} |
| 54 | sequence-length (get-sequence-length t)] |
| 55 | (each [k (pairs t)] |
| 56 | (when (not (sequence-key? k sequence-length)) |
| 57 | (table.insert keys k))) |
| 58 | (table.sort keys sort-keys) |
| 59 | (values keys sequence-length))) |
| 60 | |
| 61 | (fn count-table-appearances [t appearances] |
| 62 | (when (= (type t) "table") |
| 63 | (if (not (. appearances t)) |
| 64 | (do (tset appearances t 1) |
| 65 | (each [k v (pairs t)] |
| 66 | (count-table-appearances k appearances) |
| 67 | (count-table-appearances v appearances))) |
| 68 | (tset appearances t (+ (or (. appearances t) 0) 1)))) |
| 69 | appearances) |
| 70 | |
| 71 | |
| 72 | |
| 73 | (var put-value nil) ; mutual recursion going on; defined below |
| 74 | |
| 75 | (fn puts [self ...] |
| 76 | (each [_ v (ipairs [...])] |
| 77 | (table.insert self.buffer v))) |
| 78 | |
| 79 | (fn tabify [self] (puts self "\n" (: self.indent :rep self.level))) |
| 80 | |
| 81 | (fn already-visited? [self v] (not= (. self.ids v) nil)) |
| 82 | |
| 83 | (fn get-id [self v] |
| 84 | (var id (. self.ids v)) |
| 85 | (when (not id) |
| 86 | (let [tv (type v)] |
| 87 | (set id (+ (or (. self.max-ids tv) 0) 1)) |
| 88 | (tset self.max-ids tv id) |
| 89 | (tset self.ids v id))) |
| 90 | (tostring id)) |
| 91 | |
| 92 | (fn put-sequential-table [self t len] |
| 93 | (puts self "[") |
| 94 | (set self.level (+ self.level 1)) |
| 95 | (for [i 1 len] |
| 96 | (when (< 1 i (+ 1 len)) |
| 97 | (puts self " ")) |
| 98 | (put-value self (. t i))) |
| 99 | (set self.level (- self.level 1)) |
| 100 | (puts self "]")) |
| 101 | |
| 102 | (fn put-key [self k] |
| 103 | (if (and (= (type k) "string") |
| 104 | (: k :find "^[-%w?\\^_!$%&*+./@:|<=>]+$")) |
| 105 | (puts self ":" k) |
| 106 | (put-value self k))) |
| 107 | |
| 108 | (fn put-kv-table [self t ordered-keys] |
| 109 | (puts self "{") |
| 110 | (set self.level (+ self.level 1)) |
| 111 | ;; first, output sorted nonsequential keys |
| 112 | (each [i k (ipairs ordered-keys)] |
| 113 | (when (or self.table-edges (not= i 1)) |
| 114 | (tabify self)) |
| 115 | (put-key self k) |
| 116 | (puts self " ") |
| 117 | (put-value self (. t k))) |
| 118 | ;; next, output any sequential keys |
| 119 | (each [i v (ipairs t)] |
| 120 | (tabify self) |
| 121 | (put-key self i) |
| 122 | (puts self " ") |
| 123 | (put-value self v)) |
| 124 | (set self.level (- self.level 1)) |
| 125 | (when self.table-edges |
| 126 | (tabify self)) |
| 127 | (puts self "}")) |
| 128 | |
| 129 | (fn put-table [self t] |
| 130 | (let [metamethod (and self.metamethod? (-?> t getmetatable (. :__fennelview)))] |
| 131 | (if (and (already-visited? self t) self.detect-cycles?) |
| 132 | (puts self "#<table @" (get-id self t) ">") |
| 133 | (>= self.level self.depth) |
| 134 | (puts self "{...}") |
| 135 | metamethod |
| 136 | (puts self (metamethod t self.fennelview)) |
| 137 | :else |
| 138 | (let [(non-seq-keys len) (get-nonsequential-keys t) |
| 139 | id (get-id self t)] |
| 140 | ;; fancy metatable stuff can result in self.appearances not including |
| 141 | ;; a table, so if it's not found, assume we haven't seen it; we can't |
| 142 | ;; do cycle detection in that case. |
| 143 | (when (and (< 1 (or (. self.appearances t) 0)) self.detect-cycles?) |
| 144 | (puts self "@" id)) |
| 145 | (if (and (= (length non-seq-keys) 0) (= (length t) 0)) |
| 146 | (puts self (if self.empty-as-square "[]" "{}")) |
| 147 | (= (length non-seq-keys) 0) |
| 148 | (put-sequential-table self t len) |
| 149 | :else |
| 150 | (put-kv-table self t non-seq-keys)))))) |
| 151 | |
| 152 | (set put-value (fn [self v] |
| 153 | (let [tv (type v)] |
| 154 | (if (= tv "string") |
| 155 | (puts self (view-quote (escape v))) |
| 156 | (or (= tv "number") (= tv "boolean") (= tv "nil")) |
| 157 | (puts self (tostring v)) |
| 158 | (= tv "table") |
| 159 | (put-table self v) |
| 160 | :else |
| 161 | (puts self "#<" (tostring v) ">"))))) |
| 162 | |
| 163 | |
| 164 | |
| 165 | (fn one-line [str] |
| 166 | ;; save return value as local to ignore gsub's extra return value |
| 167 | (let [ret (-> str |
| 168 | (: :gsub "\n" " ") |
| 169 | (: :gsub "%[ " "[") (: :gsub " %]" "]") |
| 170 | (: :gsub "%{ " "{") (: :gsub " %}" "}") |
| 171 | (: :gsub "%( " "(") (: :gsub " %)" ")"))] |
| 172 | ret)) |
| 173 | |
| 174 | (fn fennelview [x options] |
| 175 | "Return a string representation of x. |
| 176 | |
| 177 | Can take an options table with these keys: |
| 178 | * :one-line (boolean: default: false) keep the output string as a one-liner |
| 179 | * :depth (number, default: 128) limit how many levels to go (default: 128) |
| 180 | * :indent (string, default: \" \") use this string to indent each level |
| 181 | * :detect-cycles? (boolean, default: true) don't try to traverse a looping table |
| 182 | * :metamethod? (boolean: default: true) use the __fennelview metamethod if found |
| 183 | * :table-edges (boolean: default: true) put {} table brackets on their own line |
| 184 | * :empty-as-square (boolean: default: false) render empty tables as [], not {} |
| 185 | |
| 186 | The __fennelview metamethod should take the table being serialized as its first |
| 187 | argument and a function as its second arg which can be used on table elements to |
| 188 | continue the fennelview process on them. |
| 189 | " |
| 190 | (let [options (or options {}) |
| 191 | inspector {:appearances (count-table-appearances x {}) |
| 192 | :depth (or options.depth 128) |
| 193 | :level 0 :buffer {} :ids {} :max-ids {} |
| 194 | :indent (or options.indent (if options.one-line "" " ")) |
| 195 | :detect-cycles? (not (= false options.detect-cycles?)) |
| 196 | :metamethod? (not (= false options.metamethod?)) |
| 197 | :fennelview #(fennelview $1 options) |
| 198 | :table-edges (not= options.table-edges false) |
| 199 | :empty-as-square options.empty-as-square}] |
| 200 | (put-value inspector x) |
| 201 | (let [str (table.concat inspector.buffer)] |
| 202 | (if options.one-line (one-line str) str)))) |