make make-temporary-file use the source location for its template argument

(This involves making make-temporary-file be a macro instead of a procedure.)

collects/racket/file.rkt

@@ -1,5 +1,7 @@
 #lang racket/base
-(require "path.rkt")
+(require "path.rkt"
+         (for-syntax racket/base
+                     setup/path-to-relative))
 
 (provide delete-directory/files
          copy-directory/files
@@ -37,7 +39,6 @@
          other-write-bit
          other-execute-bit)
 
-
 (require "private/portlines.rkt")
 
 ;; utility: sorted dirlist so functions are deterministic
@@ -83,41 +84,86 @@
     (unless (directory-exists? dir)
       (make-directory dir))))
 
-(define (make-temporary-file [template "mztmp~a"] [copy-from #f] [base-dir #f])
+(define-syntax (make-temporary-file stx)
-  (with-handlers ([exn:fail:contract?
+  (with-syntax ([app (datum->syntax stx #'#%app stx)])
-                   (lambda (x)
+    (syntax-case stx ()
-                     (raise-type-error 'make-temporary-file
+      [x (identifier? #'x) #'make-temporary-file/proc]
-                                       "format string for 1 argument"
+      [(_)
-                                       template))])
+       (let ()
-    (format template void))
+         (define line (syntax-line stx))
-  (unless (or (not copy-from)
+         (define col (syntax-column stx))
-              (path-string? copy-from)
+         (define source (syntax-source stx))
-              (eq? copy-from 'directory))
+         (define pos (syntax-position stx))
-    (raise-type-error 'make-temporary-file
+         (define str-src (cond
-                      "path, valid-path string, 'directory, or #f"
+                           [(path? source)
-                      copy-from))
+                            (path->relative-string/library source)]
-  (unless (or (not base-dir) (path-string? base-dir))
+                           [(string? source)
-    (raise-type-error 'make-temporary-file
+                            source]
-                      "path, valid-path, string, or #f"
+                           [else #f]))
-                      base-dir))
+         (define str-loc (cond
-  (let ([tmpdir (find-system-path 'temp-dir)])
+                           [(and line col) (format "-~a-~a" line col)]
-    (let loop ([s (current-seconds)]
+                           [pos (format "--~a" pos)]
-               [ms (inexact->exact (truncate (current-inexact-milliseconds)))])
+                           [else ""]))
-      (let ([name (let ([n (format template (format "~a~a" s ms))])
+         (define combined-str
-                    (cond [base-dir (build-path base-dir n)]
+           (cond
-                          [(relative-path? n) (build-path tmpdir n)]
+             [str-src (string-append str-src str-loc)]
-                          [else n]))])
+             [else (string-append "mztmp" str-loc)]))
-        (with-handlers ([exn:fail:filesystem:exists?
+         (define sanitized-str 
-                         (lambda (x)
+           (regexp-replace*
-                           ;; try again with a new name
+            #rx"[<>]"
-                           (loop (- s (random 10))
+            (regexp-replace* #rx"[\\/:]" combined-str "-")
-                                 (+ ms (random 10))))])
+            ""))
-          (if copy-from
+         (define max-len 40) ;; must be even
-              (if (eq? copy-from 'directory)
+         (define not-too-long-str
-                  (make-directory name)
+           (cond
-                  (copy-file copy-from name))
+             [(< max-len (string-length sanitized-str))
-              (close-output-port (open-output-file name)))
+              (string-append (substring sanitized-str 0 (- (/ max-len 2) 2))
-          name)))))
+                             "..."
+                             (substring sanitized-str 0 (- (/ max-len 2) 1)))]
+             [else 
+              sanitized-str]))
+         #`(app make-temporary-file/proc #,(string-append not-too-long-str "_~a")))]
+      [(_ . whatever)
+       #'(app make-temporary-file/proc . whatever)])))
+
+(define make-temporary-file/proc
+  (let ()
+    (define (make-temporary-file [template "mztmp~a"] [copy-from #f] [base-dir #f])
+      (with-handlers ([exn:fail:contract?
+                       (lambda (x)
+                         (raise-type-error 'make-temporary-file
+                                           "format string for 1 argument"
+                                           template))])
+        (format template void))
+      (unless (or (not copy-from)
+                  (path-string? copy-from)
+                  (eq? copy-from 'directory))
+        (raise-type-error 'make-temporary-file
+                          "path, valid-path string, 'directory, or #f"
+                          copy-from))
+      (unless (or (not base-dir) (path-string? base-dir))
+        (raise-type-error 'make-temporary-file
+                          "path, valid-path, string, or #f"
+                          base-dir))
+      (let ([tmpdir (find-system-path 'temp-dir)])
+        (let loop ([s (current-seconds)]
+                   [ms (inexact->exact (truncate (current-inexact-milliseconds)))])
+          (let ([name (let ([n (format template (format "~a~a" s ms))])
+                        (cond [base-dir (build-path base-dir n)]
+                              [(relative-path? n) (build-path tmpdir n)]
+                              [else n]))])
+            (with-handlers ([exn:fail:filesystem:exists?
+                             (lambda (x)
+                               ;; try again with a new name
+                               (loop (- s (random 10))
+                                     (+ ms (random 10))))])
+              (if copy-from
+                  (if (eq? copy-from 'directory)
+                      (make-directory name)
+                      (copy-file copy-from name))
+                  (close-output-port (open-output-file name)))
+              name)))))
+    make-temporary-file))
 
 (define (with-pref-params thunk)
   (parameterize ([read-case-sensitive #f]

collects/scribblings/reference/filesystem.scrbl

@@ -887,6 +887,12 @@ provided and non-@racket[#f], in which case the
 file name generated from @racket[template] is combined with
 @racket[directory] to obtain a full path.
 
+The @racket[template] argument's default is only the string @racket["mztmp~a"]
+when there is no source location information for the callsite of
+@racket[make-temporary-file] (or if @racket[make-temporary-file] is
+used in a higher-order position). If there is such information, then the template
+string is built based on the source location.
+
 If @racket[copy-from-filename] is provided as path, the temporary file
 is created as a copy of the named file (using @racket[copy-file]). If
 @racket[copy-from-filename] is @racket[#f], the temporary file is

collects/tests/racket/file.rktl

@@ -295,6 +295,16 @@
 (err/rt-test (open-output-file (build-path (current-directory) "baddir" "x"))
 	    exn:fail:filesystem?)
 
+(let ([tf (make-temporary-file)])
+  (let-values ([(base name dir?) (split-path tf)])
+    (test #t 'make-temporary-file-uses-srcloc (and (regexp-match #rx"file.rktl" (path->bytes name)) #t)))
+  (delete-file tf))
+
+(let ([tf ((λ (t) (t)) make-temporary-file)])
+  (test #t 'make-temporary-file-in-ho-position (file-exists? tf))
+  (delete-file tf))
+
+
 (define tempfilename (make-temporary-file))
 (when (file-exists? tempfilename)
   (delete-file tempfilename))