~technomancy/fennel

ref: bc1e977fd21ad0dcacf93d2f7cd8383553dce31b fennel/src/fennel/repl.fnl -rw-r--r-- 14.7 KiB
bc1e977fPhil Hagelberg Swap out locals-saving implementation with scope-aware version. 4 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
;; This module is the read/eval/print loop; for coding Fennel interactively.

;; The most complex thing it does is locals-saving, which allows locals to be
;; preserved in between "chunks"; by default Lua throws away all locals after
;; evaluating each piece of input.

(local {: sym : list &as utils} (require :fennel.utils))
(local parser (require :fennel.parser))
(local compiler (require :fennel.compiler))
(local specials (require :fennel.specials))
(local unpack (or table.unpack _G.unpack))

(fn default-read-chunk [parser-state]
  (io.write (if (< 0 parser-state.stack-size) ".." ">> "))
  (io.flush)
  (let [input (io.read)]
    (and input (.. input "\n"))))

(fn default-on-values [xs]
  (io.write (table.concat xs "\t"))
  (io.write "\n"))

;; fnlfmt: skip
(fn default-on-error [errtype err lua-source]
  (io.write
   (match errtype
     "Lua Compile" (.. "Bad code generated - likely a bug with the compiler:\n"
                       "--- Generated Lua Start ---\n"
                       lua-source
                       "--- Generated Lua End ---\n")
     "Runtime" (.. (compiler.traceback (tostring err) 4) "\n")
     _ (: "%s error: %s\n" :format errtype (tostring err)))))

;; Lua's lexical scoping mechanism is extremely hostile to repls. Without
;; implementing locals-saving in the repl, locals from each line are simply
;; discarded, forcing you to save things in globals if you want to make any
;; use of them in the repl! This is a big problem and makes the stock Lua repl
;; nearly useless. So we implement a system which wraps every form input
;; and grabs locals using debug.getlocal to stuff them into the ___replLocals___
;; table which persists across lines. It's very ugly, but it works.

(macro source-saver []
  `(do (var ___i___ 1)
       (while true
         (let [(name value) (debug.getlocal 1 ___i___)]
           (if (and name (not= "___i___" name))
               (do (set ___i___ (+ ___i___ 1))
                   (tset ___replLocals___ name value))
               (lua "break"))))))

;; a few shenanigans to work around the lack of runtime quote.
(local (_ save-source) ((-> (macrodebug (source-saver) :do)
                            (parser.string-stream)
                            (parser.parser))))

(fn wrap-save-locals [env scope form]
  (set env.___replLocals___ (or env.___replLocals___ {}))
  (let [bindings []
        result (sym (compiler.gensym scope))
        wrapped-form (list (sym :let) bindings save-source result)]
    (each [name (pairs env.___replLocals___)]
      (table.insert bindings 1 (sym name))
      (table.insert bindings 2 (list (sym ".") (sym "___replLocals___") name)))
    (table.insert bindings result)
    (table.insert bindings form)
    wrapped-form))

(fn completer [env scope text]
  (let [matches []
        input-fragment (text:gsub ".*[%s)(]+" "")]
    (var stop-looking? false)

    (fn add-partials [input tbl prefix method?] ; add partial key matches in tbl
      (each [k (utils.allpairs tbl)]
        (let [k (if (or (= tbl env) (= tbl env.___replLocals___))
                    (. scope.unmanglings k)
                    k)]
          (when (and (< (length matches) 2000)
                     ; stop explosion on too many items
                     (= (type k) :string) (= input (k:sub 0 (length input)))
                     (or (not method?) (= :function (type (. tbl k)))))
            (table.insert matches (if method?
                                      (.. prefix ":" k)
                                      (.. prefix k)))))))

    (fn descend [input tbl prefix add-matches method?]
      (let [splitter (if method? "^([^:]+):(.*)" "^([^.]+)%.(.*)")
            (head tail) (input:match splitter)
            raw-head (or (. scope.manglings head) head)]
        (when (= (type (. tbl raw-head)) :table)
          (set stop-looking? true)
          (if method?
              (add-partials tail (. tbl raw-head) (.. prefix head) true)
              (add-matches tail (. tbl raw-head) (.. prefix head))))))

    (fn add-matches [input tbl prefix]
      (let [prefix (if prefix (.. prefix ".") "")]
        (if (and (not (input:find "%.")) (input:find ":")) ; found a method call
            (descend input tbl prefix add-matches true)
            (not (input:find "%.")) ; done descending; add matches
            (add-partials input tbl prefix)
            (descend input tbl prefix add-matches false))))

    (each [_ source (ipairs [scope.specials scope.macros
                             (or env.___replLocals___ []) env env._G])]
      (add-matches input-fragment source)
      ;; bootstrap compiler doesn't yet know how to :until
      (when stop-looking? (lua :break)))
    matches))

(local commands {})

(fn command? [input]
  (input:match "^%s*,"))

(fn command-docs []
  (table.concat (icollect [name f (pairs commands)]
                  (: "  ,%s - %s" :format name
                     (or (compiler.metadata:get f :fnl/docstring) :undocumented)))
                "\n"))

;; fnlfmt: skip
(fn commands.help [_ _ on-values]
  "Show this message."
  (on-values [(.. "Welcome to Fennel.
This is the REPL where you can enter code to be evaluated.
You can also run these repl commands:

" (command-docs) "
  ,exit - Leave the repl.

Use (doc something) to see descriptions for individual macros and special forms.

For more information about the language, see https://fennel-lang.org/reference")]))

;; Can't rely on metadata being enabled at load time for Fennel's own internals.
(compiler.metadata:set commands.help :fnl/docstring "Show this message.")

(fn reload [module-name env on-values on-error]
  ;; Sandbox the reload inside the limited environment, if present.
  (match (pcall (specials.load-code "return require(...)" env) module-name)
    (true old) (let [_ (tset package.loaded module-name nil)
                     (ok new) (pcall require module-name)
                     ;; keep the old module if reload failed
                     new (if (not ok)
                             (do
                               (on-values [new])
                               old)
                             new)]
                 ;; if the module isn't a table then we can't make changes
                 ;; which affect already-loaded code, but if it is then we
                 ;; should splice new values into the existing table and
                 ;; remove values that are gone.
                 (when (and (= (type old) :table) (= (type new) :table))
                   (each [k v (pairs new)]
                     (tset old k v))
                   (each [k (pairs old)]
                     (when (= nil (. new k))
                       (tset old k nil)))
                   (tset package.loaded module-name old))
                 (on-values [:ok]))
    (false msg) (on-error :Runtime (pick-values 1 (msg:gsub "\n.*" "")))))

(fn run-command [read on-error f]
  (match (pcall read)
    (true true val) (f val)
    (false ?parse-ok ?err) (on-error :Parse "Couldn't parse input.")))

(fn commands.reload [env read on-values on-error]
  (run-command read on-error #(reload (tostring $) env on-values on-error)))

(compiler.metadata:set commands.reload :fnl/docstring
                       "Reload the specified module.")

(fn commands.reset [env _ on-values]
  (set env.___replLocals___ {})
  (on-values [:ok]))

(compiler.metadata:set commands.reset :fnl/docstring
                       "Erase all repl-local scope.")

(fn commands.complete [env read on-values on-error scope chars]
  (run-command read on-error
               #(on-values (completer env scope (-> (string.char (unpack chars))
                                                    (: :gsub ",complete +" "")
                                                    (: :sub 1 -2))))))

(compiler.metadata:set commands.complete :fnl/docstring
                       "Print all possible completions for a given input symbol.")

(fn apropos* [pattern module prefix seen names]
  ;; package.loaded can contain modules with dots in the names.  Such
  ;; names are renamed to contain / instead of a dot.
  (each [name module (pairs module)]
    (when (and (= :string (type name))
               (not= package module))
      (match (type module)
        :function (when (: (.. prefix name) :match pattern)
                    (table.insert names (.. prefix name)))
        :table (when (not (. seen module))
                 (apropos* pattern
                           module
                           (.. prefix (name:gsub "%." "/") ".")
                           (doto seen (tset module true))
                           names)))))
  names)

(fn apropos [pattern]
  ;; _G. part is stripped from patterns to provide more stable output.
  ;; The order we traverse package.loaded is arbitrary, so we may see
  ;; top level functions either as is or under the _G module.
  (let [names (apropos* pattern package.loaded "" {} [])]
    (icollect [_ name (ipairs names)]
      (name:gsub "^_G%." ""))))

(fn commands.apropos [env read on-values on-error scope]
  (run-command read on-error #(on-values (apropos (tostring $)))))

(compiler.metadata:set commands.apropos :fnl/docstring
                       "Print all functions matching a pattern in all loaded modules.")

(fn apropos-follow-path [path]
  ;; Follow path to the target based on apropos path format
  (let [paths (icollect [p (path:gmatch "[^%.]+")] p)]
    (var tgt package.loaded)
    (each [_ path (ipairs paths)]
      (set tgt (. tgt (pick-values 1 (path:gsub "%/" "."))))
      (if (= nil tgt) (lua :break)))
    tgt))

(fn apropos-doc [pattern]
  "Search function documentations for a given pattern."
  (let [names []]
    (each [_ path (ipairs (apropos ".*"))]
      (let [tgt (apropos-follow-path path)]
        (if (= :function (type tgt))
            (match (compiler.metadata:get tgt :fnl/docstring)
              docstr (when (docstr:match pattern)
                       (table.insert names path))))))
    names))

(fn commands.apropos-doc [env read on-values on-error scope]
  (run-command read on-error #(on-values (apropos-doc (tostring $)))))

(compiler.metadata:set commands.apropos-doc :fnl/docstring
                       "Print all functions that match the pattern in their docs")

(fn apropos-show-docs [on-values pattern]
  "Print function documentations for a given function pattern."
  (each [_ path (ipairs (apropos pattern))]
    (let [tgt (apropos-follow-path path)]
      (when (and (= :function (type tgt))
                 (compiler.metadata:get tgt :fnl/docstring))
        (on-values (specials.doc tgt path))
        (on-values)))))

(fn commands.apropos-show-docs [env read on-values on-error scope]
  (run-command read on-error #(apropos-show-docs on-values (tostring $))))

(compiler.metadata:set commands.apropos-show-docs :fnl/docstring
                       "Print all documentations matching a pattern in function name")

(fn load-plugin-commands []
  (when (and utils.root utils.root.options utils.root.options.plugins)
    (each [_ plugin (ipairs utils.root.options.plugins)]
      (each [name f (pairs plugin)]
        ;; first function to provide a command should win
        (match (name:match "^repl%-command%-(.*)")
          cmd-name (tset commands cmd-name (or (. commands cmd-name) f)))))))

(fn run-command-loop [input read loop env on-values on-error scope chars]
  (load-plugin-commands)
  (let [command-name (input:match ",([^%s/]+)")]
    (match (. commands command-name)
      command (command env read on-values on-error scope chars)
      _ (when (not= :exit command-name)
          (on-values ["Unknown command" command-name])))
    (when (not= :exit command-name)
      (loop))))

(fn repl [options]
  (let [old-root-options utils.root.options
        env (if options.env
                (specials.wrap-env options.env)
                (setmetatable {} {:__index (or (rawget _G :_ENV) _G)}))
        save-locals? (and (not= options.saveLocals false) env.debug
                          env.debug.getlocal)
        opts {}
        _ (each [k v (pairs options)]
            (tset opts k v))
        read-chunk (or opts.readChunk default-read-chunk)
        on-values (or opts.onValues default-on-values)
        on-error (or opts.onError default-on-error)
        pp (or opts.pp tostring) ;; make parser
        (byte-stream clear-stream) (parser.granulate read-chunk)
        chars []
        (read reset) (parser.parser (fn [parser-state]
                                      (let [c (byte-stream parser-state)]
                                        (table.insert chars c)
                                        c)))
        scope (compiler.make-scope)]
    ;; use metadata unless we've specifically disabled it
    (set opts.useMetadata (not= options.useMetadata false))
    (when (= opts.allowedGlobals nil)
      (set opts.allowedGlobals (specials.current-global-names opts.env)))
    (when (and opts.allowedGlobals save-locals?)
      (table.insert opts.allowedGlobals :___replLocals___))
    (when opts.registerCompleter
      (opts.registerCompleter (partial completer env scope)))
    (set (utils.root.options utils.root.scope) (values opts scope))

    (fn print-values [...]
      (let [vals [...]
            out []]
        (set (env._ env.__) (values (. vals 1) vals))
        ;; utils.map won't work here because of sparse tables
        (for [i 1 (select "#" ...)]
          (table.insert out (pp (. vals i))))
        (on-values out)))

    (fn loop []
      (each [k (pairs chars)]
        (tset chars k nil))
      (let [(ok parse-ok? form) (pcall read)
            src-string (string.char (unpack chars))
            form (if save-locals?
                     (wrap-save-locals env scope form)
                     form)]
        (reset)
        (if (not ok)
            (do
              (on-error :Parse parse-ok?)
              (clear-stream)
              (loop))
            (command? src-string)
            (run-command-loop src-string read loop env on-values on-error
                              scope chars)
            (when parse-ok? ; if this is false, we got eof
              (match (pcall compiler.compile form (doto opts
                                                    (tset :env env)
                                                    (tset :source src-string)
                                                    (tset :scope scope)))
                (false msg) (do
                              (clear-stream)
                              (on-error :Compile msg))
                (true src) (match (pcall specials.load-code src env)
                             (false msg) (do
                                           (clear-stream)
                                           (on-error "Lua Compile" msg src))
                             (_ chunk) (xpcall #(print-values (chunk))
                                               (partial on-error :Runtime))))
              (set utils.root.options old-root-options)
              (loop)))))

    (loop)))