From 1dc2ba7a0e967e45449460ebffce81cabc3937e6 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sun, 11 Nov 2018 20:56:10 +0100
Subject: [PATCH] Add quoted symbols as shorthand for forall

---
 NEWS                      |  7 +++++++
 manual/Types              | 10 ++++++++++
 scrutinizer.scm           | 10 ++++++++++
 tests/typematch-tests.scm | 21 +++++++++++++++++++++
 4 files changed, 48 insertions(+)

diff --git a/NEWS b/NEWS
index 18eefd7f..31fded0f 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,10 @@
+5.0.1
+
+- Type system
+  - It is now possible to quote free variables in type declarations,
+     which acts as shorthand for `forall' (thanks to "megane")
+
+
 5.0.0
 
 - Runtime system
diff --git a/manual/Types b/manual/Types
index c87ea431..587cdaa5 100644
--- a/manual/Types
+++ b/manual/Types
@@ -161,6 +161,16 @@ or {{:}} should follow the syntax given below:
 
 (*) Note: no type-variables are bound inside {{(not TYPE)}}.
 
+You can use a shorthand {{'SYMBOL}} for introducing free variables in
+{{forall}} types, for example:
+
+  ('a -> 'a) is translated to (forall (a) (a -> a))
+
+If a {{forall}} already exists, quotes around the free variables
+introduced by it will be stripped:
+
+  (forall (a) ('a -> a)) is translated to (forall (a) (a -> a))
+
 Note that type-variables in {{forall}} types may be given "constraint" types, i.e.
 
   (: sort (forall (e (s (or (vector-of e) (list-of e))))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 8209ae38..0349e136 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1972,6 +1972,16 @@
 				(second t))
 			       constraints))
 		     (validate (third t) rec)))))
+	    ((and (eq? 'quote (car t))
+		  (pair? (cdr t))
+		  (symbol? (second t))
+		  (null? (cddr t))
+		  (second t))
+	     =>
+	     (lambda (v)
+	       (unless (memq v typevars)
+		 (set! typevars (cons v typevars)))
+	       v))
 	    ((eq? 'or (car t)) 
 	     (and (list? t)
 		  (let ((ts (map validate (cdr t))))
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 4d8f40cd..97b83289 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -255,6 +255,7 @@
 (infer (forall (a) (procedure (#!rest a) a)) +)
 (infer (list fixnum) '(1))
 
+(define something)
 
 (infer port (open-input-string "foo"))
 (infer input-port (open-input-string "bar"))
@@ -398,4 +399,24 @@
   (length a) ; refine (or pair null) with list (= (list-of *))
   (infer list a))
 
+
+(assert
+ (compiler-typecase 1
+   ('a #t)))
+
+(assert
+ (compiler-typecase (the (list fixnum string string) something)
+   ((list 'a 'a 'b) #f)
+   ((list 'a 'b 'b) #t)))
+
+(assert
+ (compiler-typecase (the (list fixnum string string) something)
+   ((forall (a) (list a 'a 'b)) #f)
+   ((forall (b) (list 'a 'b b)) #t)))
+
+(assert
+ (compiler-typecase (the (list string (list string fixnum)) something)
+   ((list 'a (forall (a) (list 'b a))) #f)
+   ((list 'b (forall (b) (list b 'a))) #t)))
+
 (test-exit)
-- 
2.11.0