clone url: git://git.m455.casa/fa
esperbuild/espersrc/fennel-0.7.0/src/fennel/utils.fnl
| 1 | ;; This module contains mostly general-purpose table-related functionality that |
| 2 | ;; you might expect to see in a standard library in most langugaes, as well as |
| 3 | ;; the definitions of several core compiler types. It could be split into two |
| 4 | ;; distinct modules along those lines. |
| 5 | |
| 6 | (fn stablepairs [t] |
| 7 | "Like pairs, but gives consistent ordering every time. On 5.1, 5.2, and LuaJIT |
| 8 | pairs is already stable, but on 5.3+ every run gives different ordering." |
| 9 | (let [keys [] |
| 10 | succ []] |
| 11 | (each [k (pairs t)] |
| 12 | (table.insert keys k)) |
| 13 | (table.sort keys (fn [a b] (< (tostring a) (tostring b)))) |
| 14 | (each [i k (ipairs keys)] |
| 15 | (tset succ k (. keys (+ i 1)))) |
| 16 | (fn stablenext [tbl idx] |
| 17 | (if (= idx nil) |
| 18 | (values (. keys 1) (. tbl (. keys 1))) |
| 19 | (values (. succ idx) (. tbl (. succ idx))))) |
| 20 | (values stablenext t nil))) |
| 21 | |
| 22 | (fn map [t f out] |
| 23 | "Map function f over sequential table t, removing values where f returns nil. |
| 24 | Optionally takes a target table to insert the mapped values into." |
| 25 | (let [out (or out []) |
| 26 | f (if (= (type f) "function") |
| 27 | f |
| 28 | (let [s f] (fn [x] (. x s))))] |
| 29 | (each [_ x (ipairs t)] |
| 30 | (match (f x) |
| 31 | v (table.insert out v))) |
| 32 | out)) |
| 33 | |
| 34 | (fn kvmap [t f out] |
| 35 | "Map function f over key/value table t, similar to above, but it can return a |
| 36 | sequential table if f returns a single value or a k/v table if f returns two. |
| 37 | Optionally takes a target table to insert the mapped values into." |
| 38 | (let [out (or out []) |
| 39 | f (if (= (type f) "function") |
| 40 | f |
| 41 | (let [s f] (fn [x] (. x s))))] |
| 42 | (each [k x (stablepairs t)] |
| 43 | (let [(korv v) (f k x)] |
| 44 | (when (and korv (not v)) |
| 45 | (table.insert out korv)) |
| 46 | (when (and korv v) |
| 47 | (tset out korv v)))) |
| 48 | out)) |
| 49 | |
| 50 | (fn copy [from to] |
| 51 | "Returns a shallow copy of its table argument. Returns an empty table on nil." |
| 52 | (let [to (or to [])] |
| 53 | (each [k v (pairs (or from []))] |
| 54 | (tset to k v)) |
| 55 | to)) |
| 56 | |
| 57 | (fn member? [x tbl n] |
| 58 | (match (. tbl (or n 1)) |
| 59 | x true |
| 60 | nil false |
| 61 | _ (member? x tbl (+ (or n 1) 1)))) |
| 62 | |
| 63 | (fn allpairs [tbl] |
| 64 | "Like pairs, but if the table has an __index metamethod, it will recurisvely |
| 65 | traverse upwards, skipping duplicates, to iterate all inherited properties" |
| 66 | (assert (= (type tbl) "table") "allpairs expects a table") |
| 67 | (var t tbl) |
| 68 | (let [seen []] |
| 69 | (fn allpairs-next [_ state] |
| 70 | (let [(next-state value) (next t state)] |
| 71 | (if (. seen next-state) |
| 72 | (allpairs-next nil next-state) |
| 73 | next-state |
| 74 | (do (tset seen next-state true) |
| 75 | (values next-state value)) |
| 76 | (let [meta (getmetatable t)] |
| 77 | (when (and meta meta.__index) |
| 78 | (set t meta.__index) |
| 79 | (allpairs-next t)))))) |
| 80 | allpairs-next)) |
| 81 | |
| 82 | (fn deref [self] |
| 83 | "Get the name of a symbol." |
| 84 | (. self 1)) |
| 85 | |
| 86 | (var nil-sym nil) ; haven't defined sym yet; create this later |
| 87 | |
| 88 | (fn list->string [self tostring2] |
| 89 | (var (safe max) (values [] 0)) |
| 90 | (each [k (pairs self)] |
| 91 | (when (and (= (type k) "number") (> k max)) |
| 92 | (set max k))) |
| 93 | (for [i 1 max] |
| 94 | (tset safe i (or (and (= (. self i) nil) nil-sym) (. self i)))) |
| 95 | (.. "(" (table.concat (map safe (or tostring2 tostring)) " " 1 max) ")")) |
| 96 | |
| 97 | (local symbol-mt {1 "SYMBOL" :__fennelview deref :__tostring deref}) |
| 98 | (local expr-mt {1 "EXPR" :__tostring deref}) |
| 99 | (local list-mt {1 "LIST" :__fennelview list->string :__tostring list->string}) |
| 100 | (local sequence-marker ["SEQUENCE"]) |
| 101 | (local vararg (setmetatable ["..."] |
| 102 | {1 "VARARG" :__fennelview deref :__tostring deref})) |
| 103 | |
| 104 | (local getenv (or (and os os.getenv) (fn [] nil))) |
| 105 | |
| 106 | (fn debug-on? [flag] |
| 107 | (let [level (or (getenv "FENNEL_DEBUG") "")] |
| 108 | (or (= level "all") (level:find flag)))) |
| 109 | |
| 110 | (fn list [...] |
| 111 | "Create a new list. Lists are a compile-time construct in Fennel; they are |
| 112 | represented as tables with a special marker metatable. They only come from |
| 113 | the parser, and they represent code which comes from reading a paren form; |
| 114 | they are specifically not cons cells." |
| 115 | (setmetatable [...] list-mt)) |
| 116 | |
| 117 | (fn sym [str scope source] |
| 118 | "Create a new symbol. Symbols are a compile-time construct in Fennel and are |
| 119 | not exposed outside the compiler. Symbols have source data describing what |
| 120 | file, line, etc that they came from." |
| 121 | (let [s {:scope scope 1 str}] |
| 122 | (each [k v (pairs (or source []))] |
| 123 | (when (= (type k) "string") |
| 124 | (tset s k v))) |
| 125 | (setmetatable s symbol-mt))) |
| 126 | |
| 127 | (set nil-sym (sym "nil")) |
| 128 | |
| 129 | (fn sequence [...] |
| 130 | "Create a new sequence. Sequences are tables that come from the parser when |
| 131 | it encounters a form with square brackets. They are treated as regular tables |
| 132 | except when certain macros need to look for binding forms, etc specifically." |
| 133 | ;; can't use SEQUENCE-MT directly as the sequence metatable like we do with |
| 134 | ;; the other types without giving up the ability to set source metadata |
| 135 | ;; on a sequence, (which we need for error reporting) so embed a marker |
| 136 | ;; value in the metatable instead. |
| 137 | (setmetatable [...] {:sequence sequence-marker})) |
| 138 | |
| 139 | (fn expr [strcode etype] |
| 140 | "Create a new expression. etype should be one of: |
| 141 | :literal literals like numbers, strings, nil, true, false |
| 142 | :expression Complex strings of Lua code, may have side effects, etc |
| 143 | but is an expression |
| 144 | :statement Same as expression, but is also a valid statement (function calls) |
| 145 | :vargs varargs symbol |
| 146 | :sym symbol reference" |
| 147 | (setmetatable {:type etype 1 strcode} expr-mt)) |
| 148 | |
| 149 | (fn varg [] vararg) |
| 150 | |
| 151 | (fn expr? [x] |
| 152 | "Checks if an object is an expression. Returns the object if it is." |
| 153 | (and (= (type x) "table") (= (getmetatable x) expr-mt) x)) |
| 154 | |
| 155 | (fn varg? [x] |
| 156 | "Checks if an object is the vararg symbol. Returns the object if is." |
| 157 | (and (= x vararg) x)) |
| 158 | |
| 159 | (fn list? [x] |
| 160 | "Checks if an object is a list. Returns the object if is." |
| 161 | (and (= (type x) "table") (= (getmetatable x) list-mt) x)) |
| 162 | |
| 163 | (fn sym? [x] |
| 164 | "Checks if an object is a symbol. Returns the object if it is." |
| 165 | (and (= (type x) "table") (= (getmetatable x) symbol-mt) x)) |
| 166 | |
| 167 | (fn table? [x] |
| 168 | "Checks if an object any kind of table, EXCEPT list or symbol or vararg." |
| 169 | (and (= (type x) "table") |
| 170 | (not= x vararg) |
| 171 | (not= (getmetatable x) list-mt) |
| 172 | (not= (getmetatable x) symbol-mt) |
| 173 | x)) |
| 174 | |
| 175 | (fn sequence? [x] |
| 176 | "Checks if an object is a sequence (created with a [] literal)" |
| 177 | (let [mt (and (= (type x) "table") (getmetatable x))] |
| 178 | (and mt (= mt.sequence sequence-marker) x))) |
| 179 | |
| 180 | (fn multi-sym? [str] |
| 181 | "A multi symbol is a symbol that is actually composed of two or more symbols |
| 182 | using dot syntax. The main differences from normal symbols is that they can't |
| 183 | be declared local, and they may have side effects on invocation (metatables)." |
| 184 | (if (sym? str) (multi-sym? (tostring str)) |
| 185 | (not= (type str) "string") false |
| 186 | (let [parts []] |
| 187 | (each [part (str:gmatch "[^%.%:]+[%.%:]?")] |
| 188 | (let [last-char (part:sub (- 1))] |
| 189 | (when (= last-char ":") |
| 190 | (set parts.multi-sym-method-call true)) |
| 191 | (if (or (= last-char ":") (= last-char ".")) |
| 192 | (tset parts (+ (# parts) 1) (part:sub 1 (- 2))) |
| 193 | (tset parts (+ (# parts) 1) part)))) |
| 194 | (and (> (# parts) 0) (or (: str "match" "%.") (: str "match" ":")) |
| 195 | (not (str:match "%.%.")) |
| 196 | (not= (str:byte) (string.byte ".")) |
| 197 | (not= (str:byte (- 1)) (string.byte ".")) |
| 198 | parts)))) |
| 199 | |
| 200 | (fn quoted? [symbol] symbol.quoted) |
| 201 | |
| 202 | (fn walk-tree [root f custom-iterator] |
| 203 | "Walks a tree (like the AST), invoking f(node, idx, parent) on each node. |
| 204 | When f returns a truthy value, recursively walks the children." |
| 205 | (fn walk [iterfn parent idx node] |
| 206 | (when (f idx node parent) |
| 207 | (each [k v (iterfn node)] |
| 208 | (walk iterfn node k v)))) |
| 209 | (walk (or custom-iterator pairs) nil nil root) |
| 210 | root) |
| 211 | |
| 212 | (local lua-keywords ["and" "break" "do" "else" "elseif" "end" "false" "for" |
| 213 | "function" "if" "in" "local" "nil" "not" "or" "repeat" |
| 214 | "return" "then" "true" "until" "while" "goto"]) |
| 215 | |
| 216 | (each [i v (ipairs lua-keywords)] |
| 217 | (tset lua-keywords v i)) |
| 218 | |
| 219 | (fn valid-lua-identifier? [str] |
| 220 | (and (str:match "^[%a_][%w_]*$") (not (. lua-keywords str)))) |
| 221 | |
| 222 | (local propagated-options [:allowedGlobals :indent :correlate :useMetadata |
| 223 | :env :compiler-env]) |
| 224 | |
| 225 | (fn propagate-options [options subopts] |
| 226 | "Certain options should always get propagated onwards when a function that |
| 227 | has options calls down into compile." |
| 228 | (each [_ name (ipairs propagated-options)] |
| 229 | (tset subopts name (. options name))) |
| 230 | subopts) |
| 231 | |
| 232 | (local root {:chunk nil :scope nil :options nil :reset (fn [])}) |
| 233 | |
| 234 | (fn root.set-reset [{: chunk : scope : options : reset}] |
| 235 | (fn root.reset [] |
| 236 | (set (root.chunk root.scope root.options root.reset) |
| 237 | (values chunk scope options reset)))) |
| 238 | |
| 239 | (fn hook [event ...] |
| 240 | (when (and root.options root.options.plugins) |
| 241 | (each [_ plugin (ipairs root.options.plugins)] |
| 242 | (match (. plugin event) |
| 243 | f (f ...))))) |
| 244 | |
| 245 | {;; general table functions |
| 246 | : allpairs : stablepairs : copy : kvmap : map : walk-tree : member? |
| 247 | |
| 248 | ;; AST functions |
| 249 | : list : sequence : sym : varg : deref : expr |
| 250 | : expr? : list? : multi-sym? : sequence? : sym? : table? : varg? : quoted? |
| 251 | |
| 252 | ;; other |
| 253 | : valid-lua-identifier? : lua-keywords : hook |
| 254 | : propagate-options : root : debug-on? |
| 255 | :path (table.concat ["./?.fnl" "./?/init.fnl" (getenv "FENNEL_PATH")] ";")} |