Support saving backup and autosave files in configurable directories

This commit is "minimal changes that achieve the new functionality".

Author: LiberalArtist

gui-lib/framework/main.rkt

@@ -539,13 +539,73 @@
   path-utils:generate-autosave-name
   (-> (or/c #f path-string? path-for-some-system?) path?)
   (filename)
-  @{Generates a name for an autosave file from @racket[filename].})
+  @{
+ Generates a path for an autosave file based on @racket[filename].
+
+ @index{'path-utils:autosave-dir}
+ The value of @racket[(preferences:get 'path-utils:autosave-dir)]
+ determines the directory of the resulting path.
+ When the preference value is @racket[#f] (the default),
+ result will use the same directory as the @racket[filename]
+ (or, when @racket[filename] is @racket[#f], the directory determined by
+ @racket[(find-system-path 'doc-dir)]).
+ Otherwise, when @racket[(preferences:get 'path-utils:autosave-dir)]
+ returns a path satisfying @racket[complete-path?] and
+ @racket[directory-exists?], the autosave file will be saved in
+ that directory.
+ A relative @racket[filename] will be resolved based on
+ the value of @racket[(current-directory)].
+
+ When @racket[filename] is @racket[#f], the final element of the
+ resulting path will be an automatically-generated unique name.
+ Otherwise, the final path element will be derived from @racket[filename].
+ When @racket[(preferences:get 'path-utils:autosave-dir)] returns
+ @racket[#f], the original file name will be used directly as the base;
+ otherwise, base will be the complete path to @racket[filename],
+ encoded by replacing each seperator (@litchar{\} on Windows or
+ @litchar{/} on Unix or Mac OS) with @litchar{!}.
+ This base is transformed into the final path element in a
+ platform-specific manner:
+ @itemlist[
+ @item{On Unix and Mac OS, a @litchar{#} is added to the start
+   and end of the file’s name, then a number is added after the
+   ending @litchar{#}, and then one more @litchar{#} is appended
+   after the number.
+   The number is selected to make the autosave filename unique.}
+ @item{On Windows, the file’s extension is replaced with a number
+   to make the autosave filename unique.}
+ ]})
 
  (proc-doc/names
   path-utils:generate-backup-name
   (path? . -> . path?)
   (filename)
-  @{Generates a name for an backup file from @racket[filename].})
+  @{
+ Generates a path for a backup file based on @racket[filename].
+
+ @index{'path-utils:backup-dir}
+ The value of @racket[(preferences:get 'path-utils:backup-dir)]
+ determines the directory of the resulting path in much the same
+ way as @racket[path-utils:generate-autosave-name] responds to
+ the preference  @racket['path-utils:autosave-dir]:
+ when the value is @racket[#f] (the default), the directory of
+ @racket[filename] is used, and otherwise the directory from the
+ preference is used.
+
+ The final element of the resulting path is generated from
+ @racket[filename] in a platform-specific manner:
+ @itemlist[
+ @item{On Unix and Mac OS, a @litchar{~} is added to the end
+   of the file’s name.}
+ @item{On Windows, the file’s extension is replaced
+   with @litchar{.bak}.}]
+ In either case, when @racket[(preferences:get 'path-utils:backup-dir)]
+ returns a non-false value, the result of the above transformation
+ is combined with the complete path of @racket[filename],
+ encoded by replacing seperators with @litchar{!} as with
+ @racket[path-utils:generate-autosave-name], to form the final
+ path element.
+ })
 
  (parameter-doc
   finder:dialog-parent-parameter

gui-lib/framework/private/main.rkt

@@ -599,6 +599,31 @@
   (update-style-list 
    (color-prefs:lookup-in-color-scheme 'framework:misspelled-text-color)))
 
+;; for path-utils
+
+(define (valid-maybe-path-value? v)
+  (or (not v)
+      (and (path? v)
+           (complete-path? v)
+           (directory-exists? v))))
+
+(define (marshall:maybe-path->bytes v)
+  (and (path? v) (path->bytes v)))
+
+(define (unmarshall:maybe-bytes->path v)
+  (with-handlers ([exn:fail? (λ (e) #f)])
+    (and v (bytes->path v))))
+
+(define (initialize-backup/autosave-preference sym)
+  (preferences:set-default sym #f valid-maybe-path-value?)
+  (preferences:set-un/marshall sym
+                               marshall:maybe-path->bytes
+                               unmarshall:maybe-bytes->path))
+
+(initialize-backup/autosave-preference 'path-utils:backup-dir)
+
+(initialize-backup/autosave-preference 'path-utils:autosave-dir)
+
 ;; groups
 
 (preferences:set-default 'framework:exit-when-no-frames #t boolean?)

gui-lib/framework/private/path-utils.rkt

@@ -1,26 +1,49 @@
 #lang scheme/unit
-  (require "sig.rkt")
+  (require "sig.rkt"
+           "../preferences.rkt")
 
   (import)
   (export framework:path-utils^)
-  
-  (define (generate-autosave-name name)
-    (let-values ([(base name dir?)
-                  (if name
-                      (split-path name)
-                      (values (find-system-path 'doc-dir)
-                              (bytes->path-element #"mredauto")
-                              #f))])
-      (let* ([base (if (path? base)
-                       base
-                       (current-directory))]
-             [path (if (relative-path? base)
-                       (build-path (current-directory) base)
-                       base)])
-        (let loop ([n 1])
+
+;; preferences initialized in main.rkt
+
+(define current-backup-dir
+  (preferences:get/set 'path-utils:backup-dir))
+
+(define current-autosave-dir
+  (preferences:get/set 'path-utils:autosave-dir))
+
+  ; generate-autosave-name : (or/c #f path-string? path-for-some-system?) -> path?
+  (define (generate-autosave-name maybe-old-path)
+    (cond
+      [maybe-old-path
+       (let*-values ([(base name dir?) (split-path maybe-old-path)]
+                     [(base) (cond
+                               [(not (path? base))
+                                (current-directory)]
+                               [(relative-path? base)
+                                (build-path (current-directory) base)]
+                               [else
+                                base])])
+         (cond
+           [(current-autosave-dir)
+            =>
+            (λ (dir)
+              (make-unique-autosave-name dir (encode-as-path-element base name)))]
+           [else
+            (make-unique-autosave-name base name)]))]
+      [else
+       (make-unique-autosave-name (or (current-autosave-dir)
+                                      (find-system-path 'doc-dir))
+                                  (bytes->path-element #"mredauto"))]))
+
+
+       ; make-unique-autosave-name : dir-path path-element -> path?
+       (define (make-unique-autosave-name dir name)
+         (let loop ([n 1])
           (let* ([numb (string->bytes/utf-8 (number->string n))]
                  [new-name
-                  (build-path path
+                  (build-path dir
                               (if (eq? (system-type) 'windows)
                                   (bytes->path-element
                                    (bytes-append (regexp-replace #rx#"\\..*$" 
@@ -36,22 +59,48 @@
                                                  #"#"))))])
             (if (file-exists? new-name)
                 (loop (add1 n))
-                new-name))))))
+                new-name))))
 
   (define (generate-backup-name full-name)
     (let-values ([(pre-base name dir?) (split-path full-name)])
       (let ([base (if (path? pre-base)
                       pre-base
                       (current-directory))])
-        (let ([name-bytes (path-element->bytes name)])
-          (cond
-            [(and (eq? (system-type) 'windows)
-                  (regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
-             =>
-             (λ (m)
-               (build-path base (bytes->path-element (bytes-append (cadr m) #".bak"))))]
-            [(eq? (system-type) 'windows)
-             (build-path base (bytes->path-element (bytes-append name-bytes #".bak")))]
-            [else
-             (build-path base (bytes->path-element (bytes-append name-bytes #"~")))])))))
+        (define name-element
+          (let ([name-bytes (path-element->bytes name)])
+            (bytes->path-element
+             (cond
+               [(and (eq? (system-type) 'windows)
+                     (regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
+                =>
+                (λ (m)
+                  (bytes-append (cadr m) #".bak"))]
+               [(eq? (system-type) 'windows)
+                (bytes-append name-bytes #".bak")]
+               [else
+                (bytes-append name-bytes #"~")]))))
+        (cond
+          [(current-backup-dir)
+           =>
+           (λ (dir)
+             (build-path dir (encode-as-path-element base name-element)))]
+          [else
+           (build-path base name-element)]))))
+
+
+
+; encode-as-path-element : dir-path path-element -> path-element
+; N.B. generate-backup-name may supply a relative directory, but
+; we should always use a complete one.
+; Using simplify-path does that and ensures no 'up or 'same
+; Using ! is not completely robust, but works well enough for Emacs.
+(define (encode-as-path-element base-maybe-relative name)
+  (bytes->path-element
+   (regexp-replace* (case (system-path-convention-type)
+                      [(windows) #rx#"\\\\"]
+                      [else #rx#"/"])
+                    (path->bytes
+                     (simplify-path (build-path base-maybe-relative name)))
+                    #"!")))
+