From: Luke Lau <luke_lau@icloud.com>
Date: Sun, 21 Jul 2019 22:49:41 +0000 (+0100)
Subject: Add pretty printing for types
X-Git-Url: https://git.lukelau.me/?p=scheme.git;a=commitdiff_plain;h=76d1cd698cc577eec3a259a6937b4ada324c1bfd

Add pretty printing for types
---

diff --git a/typecheck.scm b/typecheck.scm
index 59e652a..21b874c 100644
--- a/typecheck.scm
+++ b/typecheck.scm
@@ -1,4 +1,27 @@
 (load "ast.scm")
+
+(define (abs? t)
+  (and (list? t) (eq? (car t) 'abs)))
+
+(define (tvar? t)
+  (and (not (list? t)) (not (concrete? t)) (symbol? t)))
+
+(define (concrete? t)
+  (case t
+    ('int #t)
+    ('bool #t)
+    (else #f)))
+
+(define (pretty-type t)
+  (cond ((abs? t)
+	 (string-append
+	  (if (abs? (cadr t))
+	      (string-append "(" (pretty-type (cadr t)) ")")
+	      (pretty-type (cadr t)))
+	  " -> "
+	  (pretty-type (caddr t))))
+	(else (symbol->string t))))
+
 					; ('a, ('b, 'a))
 (define (env-lookup env n)
   (if (null? env) (error #f "empty env")			; it's a type equality
@@ -137,19 +160,6 @@
       res))
   (cadr (check '() (normalize prog))))
 
-
-(define (abs? t)
-  (and (list? t) (eq? (car t) 'abs)))
-
-(define (tvar? t)
-  (and (not (list? t)) (not (concrete? t)) (symbol? t)))
-
-(define (concrete? t)
-  (case t
-    ('int #t)
-    ('bool #t)
-    (else #f)))
-
 					; returns a list of pairs of constraints
 (define (unify a b)
   (cond ((eq? a b) '())