[Chicken-hackers] [PATCH] Remove renaming detail from printed type variables

[megane]

Hi,

Here's a version of tv renaming using the plist approach Peter
suggested.

The original root symbol is not tracked as it's not needed. If there's a
need, ##core#tv-parent or somesuch could be used for tracking the
renaming chain.

>From 96799cf650b84cd02f107ec9a48c73cb51e71561 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Sun, 24 Mar 2019 09:49:00 +0200
Subject: [PATCH] Remove renaming detail from printed type variables

---
 scrutinizer.scm                           | 18 ++++++++++++++++--
 tests/scrutinizer-message-format.expected |  4 ++--
 tests/scrutiny.expected                   | 30 +++++++++++++++---------------
 3 files changed, 33 insertions(+), 19 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 7d767df..66147b9 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -43,6 +43,7 @@
        chicken.io
        chicken.pathname
        chicken.platform
+       chicken.plist
        chicken.port
        chicken.pretty-print
        chicken.string
@@ -107,6 +108,7 @@
 ;   ##compiler#special-result-type -> PROCEDURE
 ;   ##compiler#escape          ->  #f | 'yes | 'no
 ;   ##compiler#type-abbreviation -> TYPESPEC
+;;  ##compiler#tv-root         ->  STRING
 ;
 ; specialization specifiers:
 ;
@@ -1104,7 +1106,7 @@
                     (set! typeenv
                       (append (map (lambda (v)
                                      (let ((v (if (symbol? v) v (first v))))
-                                       (cons v (gensym v))))
+                                       (cons v (make-tv v))))
                                    typevars)
                               typeenv))
                     (set! constraints 
@@ -1475,6 +1477,13 @@
 
 ;;; Type-environments and -variables
 
+(define (make-tv sym)
+  (let* ((r (get sym '##core#tv-root))
+        ;; ##core#tv-root is a string to make this gensym fast
+        (new (gensym r)))
+    (put! new '##core#tv-root r)
+    new))
+
 (define (type-typeenv t)
   (let ((te '()))
     (let loop ((t t))
@@ -1926,6 +1935,7 @@
               (set! type
                 `(forall
                   ,(map (lambda (tv)
+                          (put! tv '##core#tv-root (symbol->string 
(strip-syntax tv)))
                           (cond ((assq tv constraints) => identity)
                                 (else tv)))
                         (delete-duplicates typevars eq?))
@@ -2347,6 +2357,10 @@
        s)))
 
 (define (type->pp-string t)
+  (define (pp-tv tv)
+    (let ((r (get tv '##core#tv-root)))
+      (assert r (list tv: tv))
+      (list 'quote (string->symbol r))))
   (define (conv t #!optional (tv-replacements '()))
     (define (R t) (conv t tv-replacements))
     (cond
@@ -2359,7 +2373,7 @@
        (let ((tcar (and (pair? t) (car t))))
         (cond
           ((and (eq? 'forall tcar) (every symbol? (second t))) ; no constraints
-           (let ((tvs (map (lambda (tv) (cons tv (list 'quote tv))) (second 
t))))
+           (let ((tvs (map (lambda (tv) (cons tv (pp-tv tv))) (second t))))
              (conv (third t) tvs)))
           ((eq? 'forall tcar) t) ; forall with constraints, do nothing
           ((memq tcar '(or not list vector pair list-of vector-of))
diff --git a/tests/scrutinizer-message-format.expected 
b/tests/scrutinizer-message-format.expected
index f6f3b25..d8f2aa5 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -16,7 +16,7 @@ Warning: Wrong number of arguments
 
   Procedure `cons' from module `scheme' has this type:
 
-    ('aXXX 'bXXX --> (pair 'aXXX 'bXXX))
+    ('a 'b --> (pair 'a 'b))
 
 Warning: Invalid argument
   In file `test-scrutinizer-message-format.scm:XXX',
@@ -425,7 +425,7 @@ Warning: Wrong number of arguments
 
   Procedure `cons' from module `scheme' has this type:
 
-    ('aXXX 'bXXX --> (pair 'aXXX 'bXXX))
+    ('a 'b --> (pair 'a 'b))
 
 Warning: Invalid argument
   In file `test-scrutinizer-message-format.scm:XXX',
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index cc01b6f..a16541c 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -185,7 +185,7 @@ Warning: Invalid assignment
 
   The declared type of `car' from module `scheme' is:
 
-    ((pair 'a335 *) -> 'a335)
+    ((pair 'a *) -> 'a)
 
 Warning: Let binding to `gXXX' has 2 values
   In file `scrutiny-tests.scm:XXX',
@@ -564,7 +564,7 @@ Warning: Invalid argument
 
   Procedure `apply1' has this type:
 
-    ((#!rest 'a143 -> 'b144) (list-of 'a143) -> 'b144)
+    ((#!rest 'a -> 'b) (list-of 'a) -> 'b)
 
 Warning: Invalid argument
   In file `scrutiny-tests.scm:XXX',
@@ -583,7 +583,7 @@ Warning: Invalid argument
 
   It is a call to `cons' from module `scheme' which has this type:
 
-    ('a331 'b332 -> (pair 'a331 'b332))
+    ('a 'b -> (pair 'a 'b))
 
   This is the expression:
 
@@ -591,7 +591,7 @@ Warning: Invalid argument
 
   Procedure `apply1' has this type:
 
-    ((#!rest 'a143 -> 'b144) (list-of 'a143) -> 'b144)
+    ((#!rest 'a -> 'b) (list-of 'a) -> 'b)
 
 Note: Predicate is always true
   In file `scrutiny-tests.scm:XXX',
@@ -834,7 +834,7 @@ Warning: Invalid argument
 
   It is a call to `cons' from module `scheme' which has this type:
 
-    ('a331 'b332 -> (pair 'a331 'b332))
+    ('a 'b -> (pair 'a 'b))
 
   This is the expression:
 
@@ -892,7 +892,7 @@ Warning: Invalid argument
 
   Procedure `vector-ref' from module `scheme' has this type:
 
-    ((vector-of 'a384) fixnum -> 'a384)
+    ((vector-of 'a) fixnum -> 'a)
 
 Warning: Negative vector index
   In file `scrutiny-tests.scm:XXX',
@@ -1010,7 +1010,7 @@ Warning: Invalid argument
 
   Procedure `list-ref' from module `scheme' has this type:
 
-    ((list-of 'a366) fixnum -> 'a366)
+    ((list-of 'a) fixnum -> 'a)
 
 Warning: Invalid argument
   In file `scrutiny-tests.scm:XXX',
@@ -1033,7 +1033,7 @@ Warning: Invalid argument
 
   Procedure `list-ref' from module `scheme' has this type:
 
-    ((list-of 'a366) fixnum -> 'a366)
+    ((list-of 'a) fixnum -> 'a)
 
 Warning: Invalid argument
   In file `scrutiny-tests.scm:XXX',
@@ -1056,7 +1056,7 @@ Warning: Invalid argument
 
   Procedure `list-ref' from module `scheme' has this type:
 
-    ((list-of 'a366) fixnum -> 'a366)
+    ((list-of 'a) fixnum -> 'a)
 
 Warning: Invalid argument
   In file `scrutiny-tests.scm:XXX',
@@ -1079,7 +1079,7 @@ Warning: Invalid argument
 
   Procedure `list-ref' from module `scheme' has this type:
 
-    ((list-of 'a366) fixnum -> 'a366)
+    ((list-of 'a) fixnum -> 'a)
 
 Warning: Invalid argument
   In file `scrutiny-tests.scm:XXX',
@@ -1098,7 +1098,7 @@ Warning: Invalid argument
 
   It is a call to `list-ref' from module `scheme' which has this type:
 
-    ((list-of 'a366) fixnum -> 'a366)
+    ((list-of 'a) fixnum -> 'a)
 
   This is the expression:
 
@@ -1125,7 +1125,7 @@ Warning: Invalid argument
 
   It is a call to `list-ref' from module `scheme' which has this type:
 
-    ((list-of 'a366) fixnum -> 'a366)
+    ((list-of 'a) fixnum -> 'a)
 
   This is the expression:
 
@@ -1152,7 +1152,7 @@ Warning: Invalid argument
 
   It is a call to `list-ref' from module `scheme' which has this type:
 
-    ((list-of 'a366) fixnum -> 'a366)
+    ((list-of 'a) fixnum -> 'a)
 
   This is the expression:
 
@@ -1179,7 +1179,7 @@ Warning: Invalid argument
 
   It is a call to `list-ref' from module `scheme' which has this type:
 
-    ((list-of 'a366) fixnum -> 'a366)
+    ((list-of 'a) fixnum -> 'a)
 
   This is the expression:
 
@@ -1206,7 +1206,7 @@ Warning: Invalid argument
 
   It is a call to `list-ref' from module `scheme' which has this type:
 
-    ((list-of 'a366) fixnum -> 'a366)
+    ((list-of 'a) fixnum -> 'a)
 
   This is the expression:
 
-- 
2.7.4