A facility for debugging type issues

[megane]

Hi,

here's a POC tool I've been using for a year. It prints the types known to
scrutinizer in the current scope.

I repeat, this is NOT a patch supposed to be added to core as is.

Some issues:
  - It uses a dirty hack: prints the info whenever '(##core#type-hole ...)
    is seen.
  - The usage is not pretty (I just use a editor macro to insert the form)

A nice addition would be if it told what is the expected type:

  (+ <hole>)

would tell that number is expected.

>From 89e2a655d9ba53b64d3d5186c1a4902883feaca7 Mon Sep 17 00:00:00 2001
From: megane <meganeka@gmail.com>
Date: Mon, 2 Sep 2019 10:36:04 +0300
Subject: [PATCH] * scrutinizer.scm (r-type-hole) : Add helper for inspecting
 types in scope

(define (foo l)
  (let* ([x (cons '(1) 1)]
         [y 'a]
         [z (vector 1)]
         [foo (the (list --> fixnum) length)])
    (the * '(##core#type-hole before-smash))
    (length l)
    (set-cdr! x 1)
    (the * '(##core#type-hole after-smash))))

-->

Type hole encountered:
    l : *
    x : (pair (list fixnum) fixnum)
    y : symbol
    z : (vector fixnum)
  foo : (list -> fixnum)
  ----------------------------------------
  before-smash

Type hole encountered:
    l : list
    x : pair
    y : symbol
    z : (vector *)
  foo : (list -> fixnum)
  ----------------------------------------
  after-smash
---
 scrutinizer.scm                           | 43 +++++++++++++++++++++++
 support.scm                               |  7 +++-
 tests/scrutinizer-message-format.expected |  6 ++++
 tests/test-scrutinizer-message-format.scm |  5 +++
 4 files changed, 60 insertions(+), 1 deletion(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 75cbeb15..618fa5e3 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -439,6 +439,16 @@
            class params loc dest flow)
        #;(dd "walk: ~a ~s (loc: ~a, dest: ~a, flow: ~a, blist: ~a, e: ~a)"
            class params loc dest flow blist e)
+
+       ;; Type hole
+       ;; '(##core#type-hole symbol-or-name)
+       (and-let* (((eq? 'quote class))
+                  (p1 (and (pair? (first params)) (first params)))
+                  ((eq? '##core#type-hole (car p1)))
+                  (name (and (pair? (cdr p1)) (cadr p1)))
+                  ((or (symbol? name) (string? name))))
+         (r-type-hole name e (lambda (id) (car (variable-result id e loc n 
flow)))))
+
        (set! d-depth (add1 d-depth))
        (let ((results
               (case class
@@ -3010,4 +3020,37 @@
        (sprintf "~%~%The suggested alternative is ~a."
                (variable-from-module suggestion))
        "")))
+
+(define (r-type-hole hole-name e get-type)
+  (let* ((ids (reverse
+              (filter (lambda (x) (not (variable-mark x '##compiler#temp-var)))
+                      (map car e))))
+        (entries (map (lambda (id) (cons id (get-type id))) ids)))
+    (define (name-str id)
+      (symbol->string (if (##sys#debug-mode?) id (strip-syntax id))))
+
+    (flush-output)
+    (with-output-to-port (current-error-port)
+      (lambda ()
+       (print "\nType hole encountered:")
+       (let* ((max-len (apply max 0 (map (o string-length name-str car) 
entries)))
+              (ind (+ 5 max-len))
+              (seen '()))
+         (for-each
+          (lambda (id.t)
+            (let* ((id (car id.t))
+                   (type (cdr id.t))
+                   (name (name-str id)))
+              (unless (member name seen)
+                (set! seen (cons name seen))
+                (printf "  ~a~a : ~a\n"
+                        (make-string (- max-len (string-length name)) #\ )
+                        name
+                        (substring (string-add-indent (type->pp-string type)
+                                                      (make-string ind #\ ))
+                                   (+ 2 ind))))))
+                   entries))
+       (print "  ----------------------------------------")
+       (printf "  ~s\n" hole-name)
+       (flush-output)))))
 )
diff --git a/support.scm b/support.scm
index b93fb8ef..bb1af4e9 100644
--- a/support.scm
+++ b/support.scm
@@ -218,6 +218,11 @@
     (cond ((or (zero? n) (null? vars)) (or rest '()))
           (else (cons (car vars) (loop (cdr vars) (sub1 n)))) ) ) )
 
+(define (gentmp prefix)
+  (let ((s (gensym prefix)))
+    (mark-variable s '##compiler#temp-var #t)
+    s))
+
 ;; XXX: Put this too in c-platform or c-backend?
 (define (c-ify-string str)
   (list->string
@@ -336,7 +341,7 @@
                 (constant? h) 
                 (equal? h '(##sys#void)) ) )
           (loop (cdr xs)) )
-         (else `(let ((,(gensym 't) ,(car xs)))
+         (else `(let ((,(gentmp 't) ,(car xs)))
                   ,(loop (cdr xs))) ) ) ) )
 
 ;; Only used in batch-driver: move it there?
diff --git a/tests/scrutinizer-message-format.expected 
b/tests/scrutinizer-message-format.expected
index 7688ca1f..b7d8f3d5 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -338,6 +338,12 @@ Warning: Negative vector index
 
   Procedure `vector-ref' from module `scheme' is called with a negative index 
-1.
 
+Type hole encountered:
+  x : list
+  y : fixnum
+  ----------------------------------------
+  test-type-hole
+
 Warning: Wrong number of arguments
   In file `test-scrutinizer-message-format.scm:XXX',
   In module `m',
diff --git a/tests/test-scrutinizer-message-format.scm 
b/tests/test-scrutinizer-message-format.scm
index 38f3e7a3..d9d19b59 100644
--- a/tests/test-scrutinizer-message-format.scm
+++ b/tests/test-scrutinizer-message-format.scm
@@ -46,6 +46,11 @@
  (: deprecated-foo2 (deprecated foo))
  (define deprecated-foo2 2)
 
+ (define (r-type-hole x)
+   (length x)
+   (let ((y 1))
+     '(##core#type-hole test-type-hole)))
+
  (define (toplevel-foo)
    (define (local-bar)
      (define (r-proc-call-argument-count-mismatch) (cons '()))
-- 
2.17.1