add log-once

from syntax-objects/Summer2021#3
cc @Fictitious-Rotor

index.scrbl

@@ -31,6 +31,7 @@
 @include-example{multi-check-true}
 @include-example{define-datum-literal-set}
 @include-example{rec-contract}
+@include-example{log-once}
 @include-example{marc-matcher}
 @include-example{struct-list}
 @include-example{syntax-class-contract}

log-once/log-once-test.rkt

@@ -0,0 +1,22 @@
+#lang racket/base
+(module+ test
+  (require rackunit racket/port syntax-parse-example/log-once/log-once)
+
+  (check-equal?
+    (with-output-to-string
+      (lambda ()
+        (for ([char (in-string "abcdefghijklmnopqrstuvwxyz")])
+          (log-once #:skip-count 18
+                    #:log-count 3
+                    char))))
+    "char = #\\s. \nchar = #\\t. \nchar = #\\u. \n")
+
+  (check-equal?
+    (with-output-to-string
+      (lambda ()
+        (for ([char (in-string "abcdefGhijkLmnopQrstuVwxyz")])
+          (log-once #:skip-count 2
+                    #:when (char-upper-case? char)
+                    char))))
+    "char = #\\Q. \n")
+)

log-once/log-once.rkt

@@ -0,0 +1,62 @@
+#lang racket/base
+
+(require racket/function
+         syntax/parse/define
+         (for-syntax racket/base
+                     syntax/parse
+                     racket/format
+                     syntax/parse))
+
+(provide log-once)
+
+(define log-var (curry printf "~a = ~s. "))
+(define-syntax-parser log-def
+  [(_ expr:expr)
+   #`(log-var #,(~s (syntax->datum #'expr)) expr)])
+
+(begin-for-syntax
+  (define (make-incrementor id)
+    (with-syntax ([id id])
+      #'(λ ()
+          (set! id (add1 id))
+          id))))
+
+(define-syntax-parser log-defs
+  [(_ (~optional (~seq #:newline use-newline-stx:boolean))
+      exprs*:expr ...+)
+   #:attr use-newline (syntax-e #'(~? use-newline-stx #f))
+   #:attr intermediate-newline-clause (if (attribute use-newline) #'(newline) #f)
+   #:attr ultimate-newline-clause (if (attribute use-newline) #f #'(newline))
+   #'(begin
+       (~@ (log-def exprs*)
+           (~? intermediate-newline-clause)) ...
+       (~? ultimate-newline-clause))])
+
+(define-syntax-parser log-once 
+  [(_ (~alt (~optional (~seq #:skip-count target-skip-count:nat) #:name "#:skip-count keyword"
+                       #:defaults ([target-skip-count #'0]))
+            (~optional (~seq #:log-count target-log-count:nat) #:name "#:log-count keyword"
+                       #:defaults ([target-log-count #'1]))
+            (~optional (~seq #:when condition:expr) #:name "#:when keyword")
+            (~optional (~seq #:message message:str) #:name "#:message keyword")
+            (~optional (~seq #:newline newline:boolean) #:name "#:newline keyword")) ...
+      exprs* ...+)
+   #:with logged (syntax-local-lift-expression #'#f)
+   #:with run-count (syntax-local-lift-expression #'0)
+   #:with ++run-count (make-incrementor #'run-count)
+   #:with log-count (syntax-local-lift-expression #'0)
+   #:with ++log-count (make-incrementor #'log-count)
+   #:with should-run?! (syntax-local-lift-expression
+                        #'(λ ()
+                            (and (> (++run-count) target-skip-count)
+                                 (<= (++log-count) target-log-count))))
+   #:with stop-logging?! (syntax-local-lift-expression
+                          #'(λ ()
+                              (when (<= target-log-count log-count)
+                                (set! logged #t))))
+   #'(and (not logged)
+          (when (and (~? condition)
+                     (should-run?!))
+            (~? (display message))
+            (log-defs (~? (~@ #:newline newline)) exprs* ...)
+            (stop-logging?!)))])

log-once/log-once.scrbl

@@ -0,0 +1,63 @@
+#lang syntax-parse-example
+@require[
+  (for-label racket/base (only-in racket/math natural?) syntax/parse syntax-parse-example/log-once/log-once)]
+
+@(define log-once-eval
+   (make-base-eval '(require syntax-parse-example/log-once/log-once)))
+
+@title{@tt{log-once}}
+
+@; =============================================================================
+
+@defmodule[syntax-parse-example/log-once/log-once]{}
+@stxbee2021["Fictitious-Rotor" 3]
+
+@defproc[(log-once [#:skip-count skip natural? 0]
+                   [#:log-count log-count natural? 1]
+                   [#:when cond any/c (void)]
+                   [#:message msg string? ""]
+                   [#:newline newline? boolean? #f]
+                   [expr any/c] ...) void?]{
+  The purpose of this macro is to print a sample of values within tight loops---rather
+  than inundate the console with thousands of lines of irrelevant data.
+  It achieves this purpose by providing a variety of tools that can be used to
+  constrain what is logged down to what actually interests the observer.
+
+  @examples[#:eval log-once-eval
+    (for ([char (in-string "abcdefghijklmnopqrstuvwxyz")])
+      (log-once #:skip-count 18
+                #:log-count 3
+                char))
+
+    (for ([char (in-string "abcdefGhijkLmnopQrstuVwxyz")])
+      (log-once #:skip-count 2
+                #:when (char-upper-case? char)
+                char))
+  ]
+
+  The macro replaces patterns of code that would look something like this:
+
+  @racketblock[
+    (code:comment "You have to define the variables somewhere where they won't")
+    (code:comment " fall out of scope so that the mutations matter")
+    (code:comment "You also have to be wary of leaving any of this code lying")
+    (code:comment " around once you're finished with debugging")
+    (define is-logged #f)
+    (define skip-count 0)
+    (for ([char (in-string "abcdefGhijkLmnopQrstuVwxyz")])
+      (when (and (not is-logged)
+                 (char-upper-case? char)
+                 (begin
+                   (set! skip-count (add1 skip-count))
+                   (> skip-count 2)))
+        (printf "char = ~s\n" char)
+        (set! is-logged #t)))
+  ]
+
+  The set of macros have gone through many revisions (@hyperlink["https://github.com/syntax-objects/Summer2021/issues/3" "link"]).
+  This iteration makes use of @racket[~?], @racket[~@],
+  @racket[syntax-local-lift-expression], and the excellent @racket[...].
+
+  @racketfile{log-once.rkt}
+
+}