Improve assert! error message, add extra-exprs

doc/reference/sugar.md

@@ -113,10 +113,12 @@ Evaluates body in a loop until the test expression evaluates to true.
 
 ## assert!
 ```scheme
-(assert! expr [message])
+(assert! condition-expr [message-expr extra-expr ...])
 ```
 
-Raises an error when the expression evaluates to true.
+Raises an error when the `condition-expr` evaluates to false.
+If the `message-expr` and `extra-expr`s are provided, their
+values will be included in the error message.
 
 ## hash
 ```scheme

src/std/misc/repr.ss

@@ -9,7 +9,17 @@
 
 (import
   :gerbil/gambit/hash :gerbil/gambit/ports
-  :std/misc/list :std/misc/rtd :std/sort)
+  :std/misc/rtd :std/sort)
+
+;; Definition of for-each! copied from :std/misc/list,
+;; Unlike for-each, also works on improper lists, ended by non-pairs other than '()
+;; : <- (list X) (<- X)
+(def (for-each! list fun)
+  (match list
+    ([elem . more] (fun elem) (for-each! more fun))
+    (_ (void))))
+
+;; --------------------------------------------------------
 
 ;; Default options for printing an evaluable representation. Keep it empty for now.
 ;; Note: we don't actually use options yet, but

src/std/sugar-test.ss

@@ -58,4 +58,16 @@
     (check ((is 'a test: eq?) 'a)       => #t)
     (check ((is 2.0) 2.0)               => #t)
     (check ((is "a") "a")               => #t))
+
+   (test-case "test assert! failure message"
+    (def e 'needle)
+    (def l ['stack 'of 'hay])
+    (check-exception (assert! (member e l))
+                     (lambda (e)
+                       (pregexp-match
+                        (string-append
+                         "Assertion failed \"std/sugar-test.ss\"@65.32: \\(member e l\\)\n"
+                         "  e => 'needle\n"
+                         "  l => \\['stack 'of 'hay\\]\n")
+                        (error-message e)))))
    ))

src/std/sugar.ss

@@ -25,6 +25,10 @@
   chain
   is)
 
+(import
+  (for-syntax :gerbil/expander)
+  :std/format)
+
 (defrules defrule ()
   ((_ (name args ...) body ...)
    (defrules name () ((name args ...) body ...))))
@@ -145,13 +149,51 @@
    (identifier? #'method)
    (recur klass (method method))))
 
-(defrules assert! ()
-  ((_ expr)
-   (unless expr
-     (error "Assertion failed" 'expr)))
-  ((_ expr message)
-   (unless expr
-     (error "Assertion failed" message 'expr))))
+(begin-syntax
+  ;; original idea from Jack Firth, Sam Phillips, and Alex Knauth for Rackunit:
+  ;; https://github.com/racket/rackunit/issues/149#issuecomment-919208710
+  ;; special-identifier? : Any -> Bool
+  (def (special-identifier? stx)
+    (and (identifier? stx)
+         (or (core-bound-identifier? stx)
+             (and (syntax-local-value stx false) #t))))
+
+  ;; split-sub-exprs : Stx -> [Stx [[Id Stx] ...]]
+  (def (split-sub-exprs stx)
+    (syntax-case stx ()
+      ((f a ...)
+       (not (special-identifier? #'f))
+       (with-syntax (((x ...) (gentemps #'(a ...))))
+         [(syntax/loc stx (f x ...)) #'((x a) ...)]))
+      (_ [stx []])))
+
+  ;; srcloc-string : Stx -> String
+  (def (srcloc-string stx)
+    (def loc (stx-source stx))
+    (cond (loc (call-with-output-string "" (cut ##display-locat loc #t <>)))
+          (else "?"))))
+
+(defsyntax assert!
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ condition)
+       (with-syntax (((c ((x e) ...)) (split-sub-exprs #'condition))
+                     (message (srcloc-string #'condition)))
+         #'(let ((x e) ...)
+             (assert!/where-helper c 'message 'condition [(cons 'e x) ...]))))
+      ((_ condition message)
+       (with-syntax (((c ((x e) ...)) (split-sub-exprs #'condition)))
+         #'(let ((x e) ...)
+             (assert!/where-helper c message 'condition [(cons 'e x) ...]))))
+      ((_ condition message expr ...)
+       #'(assert!/where-helper condition message 'condition [(cons 'expr expr) ...])))))
+
+(def (assert!/where-helper condition message condition-expr extras)
+  (unless condition
+   (let ()
+    (def hd (format "Assertion failed ~a: ~s" message condition-expr))
+    (def str (apply string-append hd (map (match <> ((cons k v) (format "\n  ~s => ~r" k v))) extras)))
+    (error str))))
 
 (defrule (while test body ...)
   (let lp ()