From e0f3876e8cb45d898f13c3a7b7e0cc508b7369d2 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 1 Aug 2013 13:51:49 -0400
Subject: [PATCH] indent multi-line details, export more helpers

---
 .../unstable-doc/scribblings/error.scrbl      | 13 +++++
 racket/collects/unstable/error.rkt            | 51 ++++++++++++++-----
 2 files changed, 51 insertions(+), 13 deletions(-)

diff --git a/pkgs/unstable-pkgs/unstable-doc/scribblings/error.scrbl b/pkgs/unstable-pkgs/unstable-doc/scribblings/error.scrbl
index a737e08e1e..35730a8272 100644
--- a/pkgs/unstable-pkgs/unstable-doc/scribblings/error.scrbl
+++ b/pkgs/unstable-pkgs/unstable-doc/scribblings/error.scrbl
@@ -96,4 +96,17 @@ the Racket @tech[#:doc '(lib
 "scribblings/reference/reference.scrbl")]{error message convention}.
 }
 
+@defproc[(compose-error-detail
+             [field string?]
+             [options (listof (or/c 'value 'multi 'maybe))]
+             [value any/c])
+         string?]{
+
+Formats a single detail for an error message. The @racket[options]
+behave as described in @racket[error*].
+
+The resulting string begins with a newline unless it is empty, so it
+can be appended to the end of a base error message.
+}
+
 @(close-eval the-eval)
diff --git a/racket/collects/unstable/error.rkt b/racket/collects/unstable/error.rkt
index 5e703fcad1..17854d3ec3 100644
--- a/racket/collects/unstable/error.rkt
+++ b/racket/collects/unstable/error.rkt
@@ -1,5 +1,7 @@
 #lang racket/base
 (require racket/contract/base
+         racket/string
+         racket/list
          syntax/srcloc
          syntax/stx)
 
@@ -42,7 +44,10 @@ TODO
   (->* [(or/c symbol? #f) string?]
        [#:continued (or/c string? (listof string))]
        #:rest details-list/c
-       string?)])
+       string?)]
+ [compose-error-detail
+  (-> string? (listof field-option/c) any/c
+      string?)])
 
 ;; ----
 
@@ -79,11 +84,14 @@ TODO
           (if (error-print-source-location)
               (string-append (source-location->prefix source-stx) message)
               message)])
-    (raise (exn:fail:syntax message (current-continuation-marks)
-                            (filter values (list* stx sub-stx extra-stxs))))))
+    (raise
+     (exn:fail:syntax message
+                      (current-continuation-marks)
+                      (if source-stx (cons source-stx extra-stxs) extra-stxs)))))
 
 ;; ----
 
+;; compose-error-message : .... -> string
 (define (compose-error-message who message
                                #:continued [continued-message null]
                                . field+detail-list)
@@ -91,6 +99,13 @@ TODO
     (field+detail-list->table 'compose-error-message field+detail-list null))
   (compose* who message continued-message details))
 
+;; compose-error-detail : string (listof option) any -> (listof string)
+;; Note: includes a leading newline (unless detail omitted).
+(define (compose-error-detail field options value)
+  (apply string-append (compose-detail* field options value)))
+
+;; ----
+
 (define (compose* who message continued-message details)
   (let* ([parts (apply append
                        (for/list ([detail (in-list details)])
@@ -98,7 +113,7 @@ TODO
                                 [field (if (pair? field+opts) (car field+opts) field+opts)]
                                 [options (if (pair? field+opts) (cdr field+opts) '())]
                                 [value (cdr detail)])
-                           (compose-error-detail field options value))))]
+                           (compose-detail* field options value))))]
          [parts (let loop ([continued continued-message])
                   (cond [(pair? continued) (list* "\n " (car continued) (loop (cdr continued)))]
                         [(string? continued) (loop (list continued))]
@@ -109,17 +124,27 @@ TODO
                     parts)])
     (apply string-append parts)))
 
-;; compose-error-detail : string (listof option) any -> (listof string)
-;; Note: includes a leading newline (unless detail omitted).
-(define (compose-error-detail field options value)
+(define (compose-detail* field options value)
   (let* ([value? (memq 'value options)]
          [multi? (memq 'multi options)]
          [maybe? (memq 'maybe options)]
-         [convert-value
+         [noindent? (memq 'noindent options)]
+         [convert-value0
           (cond [value?
                  (lambda (v) ((error-value->string-handler) v (error-print-width)))]
                 [else
-                 (lambda (v) (format "~a" v))])])
+                 (lambda (v) (format "~a" v))])]
+         [convert-value
+          (if noindent?
+              (lambda (v indent) (list (convert-value0 v)))
+              (lambda (v indent)
+                (let* ([s (convert-value0 v)]
+                       [lines (string-split s #rx"[\n]" #:trim? #f)]
+                       [spacing
+                        (case indent
+                          ((3) "\n   ") ;; common case, make constant
+                          (else (string-append "\n" (make-string indent #\space))))])
+                  (add-between lines spacing))))])
     (cond [(and (or maybe? multi? (not value?))
                 (not value))
            null]
@@ -131,13 +156,13 @@ TODO
                   (let value-loop ([value value])
                     (cond [(pair? value)
                            (list* "\n   "
-                                  (convert-value (car value))
-                                  (value-loop (cdr value)))]
+                                  (append (convert-value (car value) 3)
+                                          (value-loop (cdr value))))]
                           [(null? value)
                            null])))]
           [else
-           (list "\n  " field ": "
-                 (convert-value value))])))
+           (list* "\n  " field ": "
+                  (convert-value value (+ 4 (string-length field))))])))
 
 ;; ----