mREPL

mrepl.fnl

(module conjure.client.janet.mrepl
  {autoload {a conjure.aniseed.core
             str conjure.aniseed.string
             nvim conjure.aniseed.nvim
             client conjure.client
             config conjure.config
             eval conjure.aniseed.eval
             fennel conjure.aniseed.fennel
             fs conjure.fs
             log conjure.log
             mapping conjure.mapping
             stdio conjure.remote.stdio
             ts conjure.tree-sitter}
   require-macros [conjure.macros]})

(config.merge
  {:client
   {:janet
    {:mrepl
     {:mapping {:start "cs"
                :stop "cS"}

      ;; -n -> disables ansi color
      ;; -s -> raw stdin (no getline functionality)
      :command "janet -n -s"
      }}}})

(def- cfg (config.get-in-fn [:client :janet :mrepl]))

(defonce- state (client.new-state #(do {:repl nil
                                        :project-root nil
                                        :project-syspath nil})))

(var curr-id 0)

(def buf-suffix ".janet")
(def comment-prefix "# ")
(def form-node? ts.node-surrounded-by-form-pair-chars?)

(def prelude
  (a.slurp (fs.join-path [fs.conjure-source-directory
                          "resources"
                          "janet"
                          "mrepl.janet"])))

(defn- op-id []
  (set curr-id (a.inc curr-id))
  curr-id)

(defn- msg-handler [resp]
  (let [output (.. "["
                   (or (a.get resp :out)
                       (a.get resp :err))
                   "]")
        (ok? forms) (eval.str output {})]
    (log.dbg "handling" output)
    (when ok?
      (each [_ form (ipairs forms)]
        (log.append [(a.pr-str form)])))))

(defn- send [msg opts]
  (let [repl (state :repl)]
    (if repl
      (repl.send msg msg-handler)
      (log.append [(.. comment-prefix "No REPL running")]))))

(defn- make-msg [s]
  (.. s "\n"))

(defn eval-str [opts]
  (let [msg (make-msg (.. "{ "
                          "\"op\" \"eval\" "
                          "\"id\" \"" (op-id) "\" "
                          "\"len\" " (+ 1 (length opts.code)) " "
                          "}"))]
    (send (.. msg opts.code "\n") opts)))

(defn eval-file [opts]
  (eval-str (a.assoc opts :code (a.slurp opts.file-path))))

(defn doc-str [opts]
  (let [msg (make-msg {:op "doc"
                       :id (op-id)
                       :sym opts.code})]
    (send msg opts)))

(defn- display-repl-status [status]
  (let [repl (state :repl)]
    (when repl
      (log.append
        [(.. comment-prefix (a.pr-str (a.get-in repl [:opts :cmd])) " (" status ")")]
        {:break? true}))))

(defn- find-project-root []
  (let [pwd (nvim.fn.expand "%:p:h")
        file-path (fs.upwards-file-search ["project.janet"] pwd)]
    (when file-path
      (fs.parent-dir (nvim.fn.fnamemodify file-path ":p")))))

(defn stop []
  (let [repl (state :repl)]
    (when repl
      (repl.destroy)
      (display-repl-status :stopped)
      (a.assoc (state) :repl nil)
      (a.assoc (state) :project-root nil)
      (a.assoc (state) :project-syspath nil))))

(defn start []
  (if (state :repl)
    (log.append [(.. comment-prefix "Can't start, REPL is already running.")
                 (.. comment-prefix "Stop the REPL with "
                     (config.get-in [:mapping :prefix])
                     (cfg [:mapping :stop]))]
                {:break? true})
    (do
      (let [project-root (find-project-root)]
        (if project-root
          (do
            (a.assoc (state) :project-root project-root)
            (let [project-syspath (fs.join-path [project-root "jpm_tree" "lib"])]
              (when (nvim.fn.isdirectory project-syspath)
                (a.assoc (state) :project-syspath project-syspath))))
          (log.append [(.. comment-prefix "No project.janet file in parent directories")])))
      (a.assoc
        (state) :repl
        (stdio.start
          {:prompt-pattern
           (cfg [:prompt_pattern])

           :cmd
           (if (state :project-syspath)
             (.. (cfg [:command]) " -m " (state :project-syspath))
             (cfg [:command]))

           :on-success
           (fn []
             (display-repl-status :started))

           :on-error
           (fn [err]
             (display-repl-status err))

           :on-exit
           (fn [code signal]
             (when (and (= :number (type code)) (> code 0))
               (log.append [(.. comment-prefix "process exited with code " code)]))
             (when (and (= :number (type signal)) (> signal 0))
               (log.append [(.. comment-prefix "process exited with signal " signal)]))
             (stop))

           :on-stray-output
           msg-handler}))
      (send prelude {}))))

(defn on-load []
  (start))

(defn on-filetype []
  (mapping.buf
    :JanetStart (cfg [:mapping :start])
    start
    {:desc "Start the REPL"})

  (mapping.buf
    :JanetStop (cfg [:mapping :stop])
    stop
    {:desc "Stop the REPL"}))

(defn on-exit []
  (stop))

mrepl.janet

(do
  (def repl-id "0")
  (def default-source :repl)
  (def old @{})

  (var id nil)
  (var env nil)
  (var path nil)

  (defn dprint
    ```
    Prints to stdout
    ```
    [& x]
    (file/write stdout (string "<DEBUG>" ;x))
    (file/flush stdout))

  (defn respond
    ```
    Sends a message as a response
    ```
    [val &opt tag to more fd]
    (default tag "ret")
    (default to id)
    (default more {})
    (default fd stdout)
    (def msg (table/to-struct (merge {"id" to "tag" tag "val" val} more)) )
    (file/write fd (string/format "%q\n" msg))
    (file/flush fd)
    nil)

  (defn respond-err
    ```
    Sends an error message as a response
    ```
    [val &opt err-type to more fd]
    (default err-type :runtime)
    (default to id)
    (default more {})
    (def new-more (table/to-struct (merge {"type" (string "mrepl/" err-type)} more)))
    (respond val "err" to new-more fd))

  (defn done
    ```
    Sends a done message as a response
    ```
    [&opt to]
    (default to id)
    (respond nil "done" to)
    (if (= id to)
      (set id nil)))

  (defn setup-env
    ```
    Sets up an environment loaded from a file
    ```
    [new-path]
    (unless (= path new-path)
      (set env (or
                 (get module/cache new-path)
                 (do
                   (def new-env (make-env))
                   (put module/cache new-path new-env)
                   new-env)))
      (set path new-path)))

  (defn stacktrace
    ```
    Sends a message about a stacktrace

    Alternatively, if only the stacktrace is required, this function can be
    called with `no-send?` set to true.
    ```
    [fiber &opt err prefix no-send?]
    (unless (fiber? fiber)
      (error (string "error: bad slot #0, expected fiber, got " (type fiber))))
    (def frames (map (fn [frame] {:name (frame :name)
                                  :src (frame :source)
                                  :col (frame :source-column)
                                  :line (frame :source-line)})
                     (debug/stack fiber)))
    (def st (tuple/brackets ;frames))
    (if no-send?
      st
      (respond-err (string prefix err) :trace id {"st" st})))

  (defn bad-compile
    ```
    Sends a message about a bad compile
    ```
    [msg macrof where &opt line col]
    (def st (when macrof (stacktrace macrof msg "" true)))
    (respond-err (string "compile error: " msg) :compile id {"src" where "line" line "col" col "st" st}))

  (defn bad-parse
    ```
    Sends a message about a bad parse
    ```
    [p where]
    (def [line col] (:where p))
    (def s (or (:error p) "unfinished code" ))
    (respond-err (string "parse error: " s) :parse id {"src" where "line " line "col" col}))

  (defn run
    ```
    Runs code

    This function is a modified version of Janet's core `run-context` function.
    The changes are primarily concerned with removing the chunking function and
    simplifying the functions.
    ```
    [buf p]
    (def on-compile-error bad-compile)
    (def on-compile-warning warn-compile)
    (def on-parse-error bad-parse)
    (def evaluator (fn evaluate [x &] (x)))
    (def where path)
    (def guard :ydt)

    # normally located outside run-context body
    (def expand nil)
    (def lint-levels
      {:none 0
       :relaxed 1
       :normal 2
       :strict 3
       :all math/inf})

    # Read fiber status
    (defn on-status
      [f x]
      (def fs (fiber/status f))
      (if (= :dead fs)
        (do
          (put env '_ @{:value x})
          (def pf (get env *pretty-format* "%q"))
          (respond (string/format pf x)))
        (do
          (stacktrace f x)
          # (if (get env :debug) (debugger f 1))
          )))

    # Evaluate 1 source form in a protected manner
    (def lints @[])
    (defn eval1 [source &opt l c]
      (def source (if expand (expand source) source))
      (var good true)
      (var resumeval nil)
      (def f
        (fiber/new
          (fn []
            (array/clear lints)
            (def res (compile source env where lints))
            (unless (empty? lints)
              # Convert lint levels to numbers.
              (def levels (get env *lint-levels* lint-levels))
              (def lint-error (get env *lint-error*))
              (def lint-warning (get env *lint-warn*))
              (def lint-error (or (get levels lint-error lint-error) 0))
              (def lint-warning (or (get levels lint-warning lint-warning) 2))
              (each [level line col msg] lints
                (def lvl (get lint-levels level 0))
                (cond
                  (<= lvl lint-error) (do
                                        (set good false)
                                        (on-compile-error msg nil where (or line l) (or col c)))
                  (<= lvl lint-warning) (on-compile-warning msg level where (or line l) (or col c)))))
            (when good
              (if (= (type res) :function)
                (evaluator res source env where)
                (do
                  (set good false)
                  (def {:error err :line line :column column :fiber errf} res)
                  (on-compile-error err errf where (or line l) (or column c))))))
          guard
          env))
      (while (fiber/can-resume? f)
        (def res (resume f resumeval))
        (when good (set resumeval (on-status f res)))))

    # Parse and evaluate
    (def p-consume (p :consume))
    (def p-produce (p :produce))
    (def p-status (p :status))
    (def p-has-more (p :has-more))
    (parser/flush p)
    (var pindex 0)
    (var pstatus nil)
    (def len (length buf))
    (while (> len pindex)
      (+= pindex (p-consume p buf pindex))
      (while (p-has-more p)
        (def tup (p-produce p true))
        (eval1 ;[(in tup 0) ;(tuple/sourcemap tup)])
        (if (env :exit) (break)))
      (when (not= :root (p-status p))
        (def f (coro (on-parse-error p where)))
        (fiber/setenv f env)
        (resume f)
        (if (env :exit) (break))))

    (put env :exit nil)
    (in env :exit-value env))

  (defn handle-eval
    ```
    Handles an "eval" operation
    ```
    [msg p]
    (def len (or (msg "len") :line))
    (when (and (not= :line len) (not (int? len)) (not (pos? len)))
      (respond-err "bad message: len not positive integer " :msg)
      (break))
    (when (def src (or (msg "ctx") (msg "src")))
      (setup-env src)
      (parser/flush p)
      (parser/where p (or (msg "line") 1) (or (msg "col") 0)))
    (def buf @"")
    (file/read stdin len buf)
    (when (and (not= :line len) (not= len (length buf)))
      (respond-err "bad message: code shorter than len")
      (break))
    (run buf p)
    (done))

  (defn handle-stop [msg]
    (def to (msg "aim"))
    (when (nil? to)
      (respond-err "bad message: missing key \"aim\"")
      (break))
    (when (or (= id to) (= repl-id to))
      (respond-err "bad message: no matching operation matching value for key \"id\"")
      (break))
    (if (= repl-id to)
      (quit))
    (done))

  (defn handle-doc [msg]
    (when (not (string? (msg "sym")))
      (respond-err "bad message: non-string value for key \"sym\"")
      (break))
    (def sym (symbol (msg "sym")))
    (def source (or (msg "ctx") (msg "src")))
    (def doc-env (if source (get module/cache source) env))
    (def x (get doc-env sym))
    (when (or (nil? x) (nil? (x :doc)))
      (respond (string "No documentation for " sym " in " (or source path) "."))
      (break))
    (def bind-type (cond
                     (x :redef) (type (in (x :ref) 0))
                     (x :ref) (string :var " (" (type (in (x :ref) 0)) ")")
                     (x :macro) :macro
                     (x :module) (string :module " (" (x :kind) ")")
                     (type (x :value))))
    (def sm (x :source-map))
    (def d (x :doc))
    (respond d "ret" id {"type" (string bind-type) "sm" sm}))

  (defn handle-cmp [msg])

  (defn handle-msg
    ```
    Handles dispatching messages depending on operation
    ```
    [msg p]
    (set id (msg "id"))
    (case (msg "op")
      "eval"
      (handle-eval msg p)
      "stop"
      (handle-stop msg)
      "doc"
      (handle-doc msg)
      "cmp"
      (handle-cmp msg)
      (respond-err "bad message: unsupported op" :msg)))

  (defn parse-msg
    ```
    Parses message
    ```
    [buf p]
    (parser/flush p)
    (parser/consume p buf)
    (def msg (parser/produce p))
    (cond
      (not= :root (parser/status p))
      (respond-err "bad message: invalid syntax" :msg)
      (parser/has-more p)
      (respond-err "bad message: no newline between messages" :msg)
      (nil? msg)
      nil
      (not (struct? msg))
      (respond-err "bad message: not struct" :msg)
      (nil? (msg "id"))
      (respond-err "bad message: missing key \"id\"" :msg)
      (not (string? (msg "id")))
      (respond-err "bad message: non-string value for key \"id\"" :msg)
      (nil? (msg "op"))
      (respond-err "bad message: missing key \"op\"" :msg)
      msg))

  (defn read-input
    ```
    Gets chunk of input

    When evaluating input in `run-context`, this function adds the input to the
    buffer to process. If the input begins with a magic byte, the `supervise`
    function is called.
    ```
    [buf]
    (buffer/clear buf)
    (file/read stdin :line buf)
    (not (zero? (length buf))))

  (defn redirect
    ```
    Redirects an output descriptor
    ```
    [kind]
    (def old (get root-env kind))
    (def fd (case kind :out stdout :err stderr (error (string "cannot redirect " kind))))
    (put root-env kind
         (fn [x] (respond (string x) "out" id {"fd" (string "std" kind)} fd)))
    old)

  (defn redefine
    ```
    Redefines a function in the root environment
    ```
    [name f]
    (def old (get root-env name))
    (def t (table/clone old))
    (put t :value f)
    (put root-env name t)
    old)

  (defn teardown-repl
    ```
    Tears down the redirections and redefinitions
    ```
    [old]
    (each [k v] old
      (put root-env k v)))

  (defn setup-repl
    ```
    Sets up the redirections and redefinitions
    ```
    []
    (def old @{})
    (put old :redef (get root-env :redef))
    (put root-env :redef true)
    (put old :out (redirect :out))
    (put old :err (redirect :err))
    # (put old 'bad-compile (redefine 'bad-compile bad-compile))
    # (put old 'bad-parse (redefine 'bad-parse bad-parse))
    # (put old 'debug/stacktrace (redefine 'debug/stacktrace stacktrace))
    old)

  (defn repl
    ```
    Creates a REPL

    This function creates a REPL that uses mrepl's `chunks` and `on-status`
    functions.
    ```
    []
    (def old (setup-repl))
    (set env (make-env))
    (set path default-source)
    (def buf @"")
    (def msg-p (parser/new))
    (def eval-p (parser/new))
    (while (read-input buf)
      (def msg (parse-msg buf msg-p))
      (when msg
        (handle-msg msg eval-p))
      (if (dyn :exit)
        (break)))
    (done repl-id)
    # (teardown-repl old)
    )

  (respond nil "init" repl-id {"protocol" "mrepl/1"
                               "lang" (string "janet/" janet/version)
                               "os" (string (os/which))
                               "arch" (string (os/arch))})

  (repl))

spec.txt

Sendable messages:

- op: eval

This must include an ID. It can optionally include a length, a context, a source, a line and a column. If the length is included, this number of bytes will be read from stdin. If the length is not included, the following line will be treated as the source code to evaluate. This avoids needing to escape source code.

- op: stop

This must include an ID and the ID of the operation to stop.

- op: doc

This must include an ID and a symbol. It can optionally include a context.

- op: cmp

This must include an ID and a symbol. It can optionally include a context.

Receivable messages:

- tag: init

This will include the protocol version and an ID that can be used to stop the REPL. It can optionally include the runtime version, the system architecture and the system OS.

- tag: ret

This will include the ID of the operation that is being returned and the return value. It can optionally include the time taken to execute.

- tag: err

This will include the ID of the operation that failed as well as a message. It can optionally include a stacktrace, the source, the line and the column.

- tag: out

This will include the ID of the operation that produced the output, a descriptor (either stdout or stderr) and a value for the output.

- tag: done

This will include the ID of the operation that is finished.