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,6 +84,50 @@
     (unless (directory-exists? dir)
       (make-directory dir))))
 
+(define-syntax (make-temporary-file stx)
+  (with-syntax ([app (datum->syntax stx #'#%app stx)])
+    (syntax-case stx ()
+      [x (identifier? #'x) #'make-temporary-file/proc]
+      [(_)
+       (let ()
+         (define line (syntax-line stx))
+         (define col (syntax-column stx))
+         (define source (syntax-source stx))
+         (define pos (syntax-position stx))
+         (define str-src (cond
+                           [(path? source)
+                            (path->relative-string/library source)]
+                           [(string? source)
+                            source]
+                           [else #f]))
+         (define str-loc (cond
+                           [(and line col) (format "-~a-~a" line col)]
+                           [pos (format "--~a" pos)]
+                           [else ""]))
+         (define combined-str
+           (cond
+             [str-src (string-append str-src str-loc)]
+             [else (string-append "mztmp" str-loc)]))
+         (define sanitized-str 
+           (regexp-replace*
+            #rx"[<>]"
+            (regexp-replace* #rx"[\\/:]" combined-str "-")
+            ""))
+         (define max-len 40) ;; must be even
+         (define not-too-long-str
+           (cond
+             [(< max-len (string-length sanitized-str))
+              (string-append (substring sanitized-str 0 (- (/ max-len 2) 2))
+                             "..."
+                             (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)
@@ -118,6 +163,7 @@
                       (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))