Send the current s-expression to the interactions window (quickscript)

select-or-send-sexp.rkt

#lang racket/base

(require quickscript
         racket/list
         racket/class
         framework
         racket/gui/base)

;;; Author: Laurent Orseau https://github.com/Metaxal
;;; License: [Apache License, Version 2.0](http://www.apache.org/licenses/LICENSE-2.0) or
;;;          [MIT license](http://opensource.org/licenses/MIT) at your option.

(script-help-string "Selects the current s-expression or sends it to the interactions")

(define (opening-delimiter? c)
  (member c (list #\( #\[ #\{)))

(define (closing-delimiter? c)
  (member c (list #\) #\] #\})))

;; TODO: Use classify-position? Requires the tokenizer to be running though
(define (get-user-sexp-range ed start)
  (define ranges (send ed get-highlighted-ranges))
  ; Find the first range for which the cursor is either
  (define r1
    (for/or ([r (in-list ranges)])
      (and (<= (text:range-start r) start (text:range-end r))
           r)))
  (cond
    ;; If a sexp is already highlighted by DrRacket,
    ;; just use that.
    [r1
     (values (text:range-start r1) (text:range-end r1))]
    ;; Otherwise we make our own rules about which sexp to use.
    [else
     (define char-left (if (> start  0)
                         (send ed get-character (- start 1))
                         #\nul))
     (define char-right (send ed get-character start))
     (define left-ws? (char-whitespace? char-left))
     (define right-ws? (char-whitespace? char-right))
     ;; These helpers return the start position pos of the
     ;; (left, right, up) sexp
     ;; if there is a sexp at the right of pos.
     (define (try-left)
       (define pos (send ed get-backward-sexp start))
       (and pos (send ed get-forward-sexp pos) pos))
     (define (try-right)
       (and (send ed get-forward-sexp start) start))
     (define (try-up)
       (define pos (send ed find-up-sexp start))
       (and pos (send ed get-forward-sexp pos) pos))
     (define sexp-start
       (cond
         [(and left-ws? right-ws?)
          (or (try-up) (try-right) (try-left))]
         [left-ws?
          (or (try-right) (try-up) (try-left))]
         [right-ws?
          (or (try-left) (try-up) (try-right))]
         [(opening-delimiter? char-left)
          (or (try-right) (try-up) (try-left))]
         [(closing-delimiter? char-right)
          (or (try-left) (try-up) (try-right))]
         [else
          (or (try-up) (try-right) (try-left))]))
     (define sexp-end (and sexp-start (send ed get-forward-sexp sexp-start)))
     (values sexp-start sexp-end)]))

(define-script send-sexp-to-interactions
  #:label "Send sexp to interactions"
  #:shortcut #\return
  #:shortcut-prefix (shift ctl)
  (λ (selection #:definitions defs #:editor ed #:interactions ints)
    (when (eq? defs ed)
      (define start (send ed get-start-position))
      (define end (send ed get-end-position))

      (define-values (sexp-start sexp-end)
        (if (= start end)
          (get-user-sexp-range ed start)
          (values start end)))
      (when sexp-end
        (define str (send ed get-text sexp-start sexp-end))
        (send ints set-position (send ints last-position))
        (send ints insert (string-append str "\n"))
        (send ints do-submission) ; submit the expression pending in the interactions
        ; Trying to give the focus back to the definitinos after an exception, but
        ; couldn't make it work.
        #;(send (send defs get-canvas) focus)))
    #f))

(define-script select-user-sexp
  #:label "Select user sexp"
  #:shortcut #\return
  #:shortcut-prefix (ctl)
  (λ (selection #:definitions defs #:editor ed)

    (when (eq? defs ed)
      (define start (send ed get-start-position))
      (define end (send ed get-end-position))

      (when (= start end)
        (define-values (sexp-start sexp-end)
          (get-user-sexp-range ed start))
        (when sexp-end
          (send ed set-position sexp-start sexp-end))))
    #f))

(module url2script-info racket/base
  (provide filename url)
  (define filename "select-or-send-sexp.rkt")
  (define url "https://gist.github.com/Metaxal/9f313c17269f9cbcc95f614385309fb8"))