Reformats path-utils to match modern Racket

Author: LiberalArtist

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

@@ -1,10 +1,11 @@
-#lang scheme/unit
-  (require "sig.rkt"
-           racket/list
-           "../preferences.rkt")
+#lang racket/unit
+
+(require "sig.rkt"
+         racket/list
+         "../preferences.rkt")
 
-  (import)
-  (export framework:path-utils^)
+(import)
+(export framework:path-utils^)
 
 ;; preferences initialized in main.rkt
 
@@ -22,83 +23,80 @@
 (define current-autosave-dir
   (make-getter/ensure-exists '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 dir
-                              (if (eq? (system-type) 'windows)
-                                  (bytes->path-element
-                                   (bytes-append (regexp-replace #rx#"\\..*$" 
-                                                                 (path-element->bytes name)
-                                                                 #"")
-                                                 #"."
-                                                 numb))
-                                  (bytes->path-element
-                                   (bytes-append #"#"
-                                                 (path-element->bytes name)
-                                                 #"#"
-                                                 numb
-                                                 #"#"))))])
-            (if (file-exists? new-name)
-                (loop (add1 n))
-                new-name))))
-
-  ;; generate-backup-name : path? -> path?
-  (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))])
-        (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)]))))
- 
- 
- 
+; 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)
+  (define sys
+    (system-path-convention-type))
+  (let loop ([n 1])
+    (let* ([numb (string->bytes/utf-8 (number->string n))]
+           [new-name
+            (build-path dir
+                        (case sys
+                          [(windows)
+                           (path-replace-extension name
+                                                   (bytes-append #"."
+                                                                 numb))]
+                          [else
+                           (bytes->path-element
+                            (bytes-append #"#"
+                                          (path-element->bytes name)
+                                          #"#"
+                                          numb
+                                          #"#"))]))])
+      (if (file-exists? new-name)
+          (loop (add1 n))
+          new-name))))
+
+
+;; generate-backup-name : path? -> path?
+(define (generate-backup-name full-name)
+  (define-values (pre-base old-name dir?)
+    (split-path full-name))
+  (define base
+    (if (path? pre-base)
+        pre-base
+        (current-directory)))
+  (define name-element
+    (case (system-path-convention-type)
+      [(windows)
+       (path-replace-extension old-name #".bak")]
+      [else
+       (bytes->path-element
+        (bytes-append (path-element->bytes old-name) #"~"))]))
+  (cond
+    [(current-backup-dir)
+     =>
+     (λ (dir)
+       (build-path dir (encode-as-path-element base name-element)))]
+    [else
+     (build-path base name-element)]))
+
+
 (define candidate-separators
   `(#"!" #"%" #"_" #"|" #":" #">" #"^" #"$" #"@" #"*" #"?"))