Workspaces for DrRacket (quickscript)

workspaces.rkt

#lang racket/base

;;; 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.

;;; See also: https://pkgs.racket-lang.org/package/drracket-restore-workspace

(require quickscript
         racket/class
         racket/match
         racket/file
         racket/list
         racket/gui/base)

(script-help-string "Save and restore DrRacket tabs and cursor positions.")

;; Opens a file in a new tab and returns whether opening was successful.
;; Checks if the file exists and displays a message box otherwise and returns #f.
;; Opens the file in the first tab if drracket is still-untouched?
;; Changes to the corresponding tab if the file is already open.
;; TODO: Move this function to quickscript/utils (?) as it's quite useful!
;; appears also in quickscript-competition-2020/open-recent and open-multi.rkt (gist).
(define (smart-open-file drfr f)
  (cond
    [(not (file-exists? f))
     (message-box "Error"
                  (format "File not found: ~a" f)
                  drfr
                  '(ok stop))
     #f]
    [(send drfr still-untouched?)
     (send drfr change-to-file f)
     #t]
    [(send drfr find-matching-tab f)
     =>
     (λ (tab)
       (send drfr change-to-tab tab)
       #t)]
    [else
     (send drfr open-in-new-tab f)
     #t]))

(define-script save-workspace
  #:label "&Save workspace…"
  #:menu-path ("&Workspaces")
  (λ (selection #:frame fr)
    (define current-dir (send (send fr get-current-tab) get-directory))
    (define fout
      (put-file "Save workspace"
                fr
                current-dir
                "workspace.rktw"
                ".rktw"
                '()
                '(("DrRacket workspace" "*.rktw")
                  ("Any" "*.*"))))
    (when fout
      (write-to-file
       #:exists 'replace
       (for/list ([tab (in-list (send fr get-tabs))]
                  #:when (send tab get-directory))
         (define defs (send tab get-defs))
         (define pth (send defs get-filename))
         (list (if (path? pth) (path->string pth) pth)
               (send defs get-start-position)
               (send defs get-end-position)))
       fout))
    #f))

(define-script restore-workspace
  #:label "&Restore workspace…"
  #:menu-path ("&Workspaces")
  (λ (selection #:frame fr)
    (define fin
      (get-file "Restore workspace"
                fr
                #false
                #false
                ".rktw"
                '()
                '(("DrRacket workspace" "*.rktw")
                  ("Any" "*.*"))))
    
    (when (and fin (file-exists? fin))
      (define fv (file->value fin))
      #;(send fr begin-container-sequence)
      (let ([fr (cond [(send fr still-untouched?) fr]
                      [else
                       (define open-new-window
                         (dynamic-require 'drracket/tool-lib
                                          'drracket:unit:open-drscheme-window))
                       (define fr (open-new-window #f))
                       fr])])
        (define first-tab? #true)
        (define new-infos
          (for/list ([info (in-list fv)])
            (match info
              [(list pth rst ...)
               (and pth (smart-open-file fr pth) rst)])))
      
      (for ([info (in-list new-infos)]
            [tab (in-list (send fr get-tabs))])
        (match info
          [(list start-pos end-pos)
           (define defs (send tab get-defs))
           (send defs set-position start-pos end-pos)]
          [else (void)]))
      #;(send fr end-container-sequence))) ; buggy, not sure why
    #f))

(module url2script-info racket/base
  (provide filename url)
  (define filename "workspaces.rkt")
  (define url "https://gist.githubusercontent.com/Metaxal/f5ea8e94b802eac947fe9ea72870624b"))