From a64f7097fa246c19a4c69d0aad65e60378273887 Mon Sep 17 00:00:00 2001
From: Luke Lau <luke_lau@icloud.com>
Date: Fri, 2 Aug 2019 15:45:26 +0100
Subject: [PATCH] Start work on ADTs

---
 ast.scm       |  36 ++++++++++++---
 codegen.scm   |  14 +++---
 main.scm      |   9 +++-
 tests.scm     | 109 ++++++++++++++++++++++++++------------------
 typecheck.scm | 123 ++++++++++++++++++++++++++++----------------------
 5 files changed, 179 insertions(+), 112 deletions(-)

diff --git a/ast.scm b/ast.scm
index 2beb945..469a96f 100644
--- a/ast.scm
+++ b/ast.scm
@@ -38,14 +38,14 @@
   (define (inner y) (ast-collect f y))
   (case (ast-type x)
     ['let (append (f x)
-		  (fold-map inner (let-bindings x))
-		  (fold-map inner (let-body x)))]
+		  (flat-map inner (let-bindings x))
+		  (flat-map inner (let-body x)))]
     ['app (append (f x)
-		  (fold-map inner x))]
+		  (flat-map inner x))]
     ['lambda (append (f x)
 		     (inner (lambda-body x)))]
     ['if (append (f x)
-		 (fold-map inner (cdr x)))]
+		 (flat-map inner (cdr x)))]
     [else (f x)]))
 
 (define (ast-find p x)
@@ -70,12 +70,36 @@
     ['if (either (p x) (any inner (cdr x)))]
     [else (p x)]))
 
-(define let-bindings cadr)
+(define (let-bindings e)
+  (define (extract x)  ) ; TODO
+  (flat-map extract (cadr e))
 (define let-body cddr)
 
 (define (lambda? x)
   (and (list? x) (eq? (car x) 'lambda)))
 
+
+(define (statement-type x)
+  (cond
+   [(and (list? x)
+	 (eqv? (car x) 'data)) 'data]
+   [(and (list? x)
+	 (eqv? (car x) 'define)) 'define]
+   [else 'expr]))
+
+(define (program-datas program)
+  (filter (lambda (x) (eqv? (statement-type x) 'data))
+	  program))
+
+(define (program-defines program)
+  (filter (lambda (x) (eqv? (statement-type x) 'defines))
+	  program))
+
+(define (program-body program)
+  `(let ()
+     ,@(filter (lambda (x) (eqv? (statement-type x) 'expr))
+	       program)))
+
 ; for use in normalized form
 (define lambda-arg caadr)
 ; for use elsewhere
@@ -83,7 +107,7 @@
 (define lambda-body caddr)
 
 ; utils
-(define (fold-map f x) (fold-left append '() (map f x)))
+(define (flat-map f x) (fold-left append '() (map f x)))
 (define (repeat x n) (if (<= n 0) '()
 			 (cons x (repeat x (- n 1)))))
 
diff --git a/codegen.scm b/codegen.scm
index 7a12fc2..fb856a5 100644
--- a/codegen.scm
+++ b/codegen.scm
@@ -349,15 +349,15 @@
 	    (set! bound (append (lambda-args e) bound))
 	    (collect (lambda-body e))))
 
-      ('app (fold-map collect e))
-      ('if (fold-map collect (cdr e)))
+      ('app (flat-map collect e))
+      ('if (flat-map collect (cdr e)))
       ('let
-	  (let ([bind-fvs (fold-map (lambda (a)
+	  (let ([bind-fvs (flat-map (lambda (a)
 				      (begin
 					(set! bound (cons (car a) bound))
 					(collect (cdr a))))
 				    (let-bindings e))])
-	    (append bind-fvs (fold-map collect (let-body e)))))
+	    (append bind-fvs (flat-map collect (let-body e)))))
       (else '())))
   (collect prog))
 
@@ -523,7 +523,9 @@
 (define (codegen program)
   (set! cur-label 0)
   (set! cur-lambda 0)
-  (let* ((extract-res-0 (extract-strings program))
+  (let* ([body (program-body program)]	
+	 
+	 (extract-res-0 (extract-strings body))
 	 (strings (car extract-res-0))
 	 (extract-res-1 (extract-lambdas (cdr extract-res-0)))
 	 (lambdas (car extract-res-1))
@@ -559,7 +561,7 @@
 
 (define (compile-to-binary program output t)
   (set! target t)
-  (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
+  (when (not (eq? (typecheck program) 'Int)) (error #f "not an Int"))
   (let ([tmp-path "/tmp/a.s"])
     (when (file-exists? tmp-path) (delete-file tmp-path))
     (with-output-to-file tmp-path
diff --git a/main.scm b/main.scm
index e2e96b8..df8e656 100644
--- a/main.scm
+++ b/main.scm
@@ -28,8 +28,13 @@
 (define target (car (parse-args)))
 (define file (cadr (parse-args)))
 
+(define (read-prog port)
+  (if (port-input-empty? port)
+      '()
+      (cons (read) (read-prog port))))
+
 (compile-to-binary
  (if (eqv? file 'stdin)
-     (read)
-     (call-with-input-file file read))
+     (read-prog (current-input-port))
+     (call-with-input-file file read-prog))
  "a.out" target)
diff --git a/tests.scm b/tests.scm
index 15e14ea..4e50dc6 100644
--- a/tests.scm
+++ b/tests.scm
@@ -32,6 +32,9 @@
   (compile-to-binary prog "/tmp/test-prog" host-os)
   (test (system "/tmp/test-prog") exit-code))
 
+(define (test-expr prog exit-code)
+  (test-prog (list prog) exit-code))
+
 (define (test-prog-stdout prog output)
   (display prog)
   (newline)
@@ -40,95 +43,115 @@
   (let ((str (read-file "/tmp/test-output.txt")))
     (test str output)))
 
-(test-types (typecheck '(lambda (x) (+ ((lambda (y) (x y 3)) 5) 2)))
-	    '(abs (abs int (abs int int)) int))
+(test-types (typecheck '((lambda (x) (+ ((lambda (y) (x y 3)) 5) 2))))
+	    '(abs (abs Int (abs Int Int)) Int))
 
 					; recursive types
 
 (test-types (substitute '((t1 . (abs t1 t10))) 't1) '(abs t1 t10))
 
-(test-types (typecheck '(let ([bar (lambda (y) y)]
+(test-types (typecheck '((let ([bar (lambda (y) y)]
 			       [foo (lambda (x) (foo (bar #t)))])
-			  foo))
-	    '(abs bool a))
+			   foo)))
+	    '(abs Bool a))
 
-(test-types (typecheck '(let ([bar (lambda (y) y)]
+(test-types (typecheck '((let ([bar (lambda (y) y)]
 			       [foo (lambda (x) (foo (bar #t)))])
-		    bar))
+			   bar)))
 	    '(abs a a))
 
-(test-types (typecheck '(let ([foo 3]
+(test-types (typecheck '((let ([foo 3]
 			       [bar (+ foo baz)]
 			       [baz (- bar 1)])
-			  bar))
-	    'int)
+			   bar)))
+	    'Int)
 
-(test-types (typecheck '(let ([foo 3]
+(test-types (typecheck '((let ([foo 3]
 			       [bar (baz foo)]
 			       [baz (lambda (x) x)])
-			  baz))
+			   baz)))
 	    '(abs a a))
 
-(test-types (typecheck '(let ([foo 3]
+(test-types (typecheck '((let ([foo 3]
 			       [bar (baz foo)]
 			       [baz (lambda (x) x)])
-			  bar))
-	    'int)
+			   bar)))
+	    'Int)
 
 					; mutual recursion
-(test-types (typecheck '(let ([f (lambda (n) (if (= n 0)
+(test-types (typecheck '((let ([f (lambda (n) (if (= n 0)
 						  0
 						  (+ 1 (g (- n 1)))))]
 			       [g (lambda (m) (f m))])
-			  (f 10)))
-	    'int)
+			   (f 10))))
+	    'Int)
 
-(test-types (typecheck '(let ([pow (lambda (p y)
+(test-types (typecheck '((let ([pow (lambda (p y)
 				      (let ([go (lambda (n x)
 						  (if (= n 0)
 						      x
 						      (go (- n 1) (* x y))))])
 					(go p 1)))])
-			  (pow 4 2)))
-	    'int)
-
-(test-prog '(+ 1 2) 3)
-(test-prog '(bool->int (= 2 0)) 0)
-(test-prog '((lambda (x) ((lambda (y) (+ x y)) 42)) 100) 142)
-
-(test-prog '(* 10 5) 50)
-
-(test-prog '(let ((x (+ 1 32))
+			   (pow 4 2))))
+	    'Int)
+
+(test-types
+ (typecheck
+  '((data A
+	  [foo Int]
+	  [bar Bool])
+    (let ([x (foo 42)]
+	  [(foo y) x])
+      x)))
+ 'A)
+
+(test-types
+ (typecheck
+  '((data A
+	  [foo Int]
+	  [bar Bool])
+    (let ([x (foo 42)]
+	  [(foo y) x])
+      y)))
+  'Int)
+
+(test-expr '(+ 1 2) 3)
+(test-expr '(bool->int (= 2 0)) 0)
+(test-expr '((lambda (x) ((lambda (y) (+ x y)) 42)) 100) 142)
+
+(test-expr '(* 10 5) 50)
+
+(test-expr '(let ((x (+ 1 32))
 		  (y x))
 	      ((lambda (z) (+ 2 z)) (* y x)))
 	   67) ; exit code modulos at 256
-(test-prog '(if ((lambda (x) (= x 2)) 1) 0 (- 32 1)) 31)
+(test-expr '(if ((lambda (x) (= x 2)) 1) 0 (- 32 1)) 31)
 
-(test-prog-stdout '(if (= 3 2) 1 (let () (print "hello world!") 0)) "hello world!")
+(test-prog-stdout '((if (= 3 2) 1 (let () (print "hello world!") 0))) "hello world!")
 
-(test-prog '((lambda (x y) (+ x y)) 1 2) 3)
-(test-prog '((lambda (x) (+ ((lambda (y) (+ y 1)) 3) x)) 2) 6)
+(test-expr '((lambda (x y) (+ x y)) 1 2) 3)
+(test-expr '((lambda (x) (+ ((lambda (y) (+ y 1)) 3) x)) 2) 6)
 
 					; passing closures about
-(test-prog '((lambda (z) ((lambda (x) (x 1)) (lambda (y) (+ z y)))) 2) 3)
+(test-expr '((lambda (z) ((lambda (x) (x 1)) (lambda (y) (+ z y)))) 2) 3)
 
 					; passing builtins about
-(test-prog '((lambda (x) ((lambda (a b) (a b 3)) + x)) 3) 6)
-(test-prog '(bool->int ((lambda (x) (x #f)) !)) 1)
-(test-prog '((lambda (f) (f #t)) bool->int) 1)
-(test-prog-stdout '(let () ((lambda (f) (f "foo")) print) 0) "foo")
-(test-prog '((lambda (f) (f 3 3)) (lambda (x y) (bool->int (= x y)))) 1)
-(test-prog '(bool->int ((lambda (f) (! (f 2 3))) =)) 1)
+(test-expr '((lambda (x) ((lambda (a b) (a b 3)) + x)) 3) 6)
+(test-expr '(bool->int ((lambda (x) (x #f)) !)) 1)
+(test-expr '((lambda (f) (f #t)) bool->int) 1)
+(test-prog-stdout '((let () ((lambda (f) (f "foo")) print) 0)) "foo")
+(test-expr '((lambda (f) (f 3 3)) (lambda (x y) (bool->int (= x y)))) 1)
+(test-expr '(bool->int ((lambda (f) (! (f 2 3))) =)) 1)
 
 					; recursion
-(test-prog '(let [(inc (lambda (f n x)
+(test-expr '(let [(inc (lambda (f n x)
 			 (if (= n 0)
 			     x
 			     (f f (- n 1) (+ x 1)))))]
 	      (inc inc 3 2))
 	   5)
 
-(test-prog '(let ([go (lambda (n m x)
+(test-expr '(let ([go (lambda (n m x)
 			(if (= n 0)
 			     x
 			     (go (- n 1) m (* x m))))]
@@ -137,7 +160,7 @@
 	      (pow 3 2))
 	   8)
 
-(test-prog '(let ([pow (lambda (p y)
+(test-expr '(let ([pow (lambda (p y)
 			 (let ([go (lambda (n x)
 				     (if (= n 0)
 					 x
diff --git a/typecheck.scm b/typecheck.scm
index 57a7815..4cc9349 100644
--- a/typecheck.scm
+++ b/typecheck.scm
@@ -4,14 +4,13 @@
   (and (list? t) (eq? (car t) 'abs)))
 
 (define (tvar? t)
-  (and (not (list? t)) (not (concrete? t)) (symbol? t)))
+  (and (not (list? t))
+       (not (concrete? t))
+       (symbol? t)))
 
 (define (concrete? t)
-  (case t
-    ('int #t)
-    ('bool #t)
-    ('void #t)
-    (else #f)))
+  (and (symbol? t)
+       (char-upper-case? (string-ref (symbol->string t) 0))))
 
 (define (pretty-type t)
   (cond ((abs? t)
@@ -82,46 +81,16 @@
 
 (define (builtin-type x)
   (case x
-    ('+ '(abs int (abs int int)))
-    ('- '(abs int (abs int int)))
-    ('* '(abs int (abs int int)))
-    ('! '(abs bool bool))
-    ('= '(abs int (abs int bool)))
-    ('bool->int '(abs bool int))
-    ('print '(abs string void))
-    (else #f)))
-
-(define (check env x)
-  ;; (display "check: ")
-  ;; (display x)
-  ;; (display "\n\t")
-  ;; (display env)
-  ;; (newline)
-  (let
-      ((res
-	(case (ast-type x)
-	  ('int-literal (list '() 'int))
-	  ('bool-literal (list '() 'bool))
-	  ('string-literal (list '() 'string))
-	  ('builtin (list '() (builtin-type x)))
-
-	  ('if
-	   (let* ((cond-type-res (check env (cadr x)))
-		  (then-type-res (check env (caddr x)))
-		  (else-type-res (check env (cadddr x)))
-		  (then-eq-else-cs (~ (cadr then-type-res)
-				      (cadr else-type-res)))
-		  (cs (constraint-merge
-		       (car then-type-res)
-		       (constraint-merge (car else-type-res)
-					 then-eq-else-cs)))
-		  (return-type (substitute cs (cadr then-type-res))))
-	     (when (not (eqv? (cadr cond-type-res) 'bool))
-	       (error #f "if condition isn't bool"))
-	     (list cs return-type)))
-	  
-	  ('var (list '() (env-lookup env x)))
-	  ('let
+    ('+ '(abs Int (abs Int Int)))
+    ('- '(abs Int (abs Int Int)))
+    ('* '(abs Int (abs Int Int)))
+    ('! '(abs Bool Bool))
+    ('= '(abs Int (abs Int Bool)))
+    ('bool->int '(abs Bool Int))
+    ('print '(abs String Void))
+    (else (error #f "Couldn't find type for builtin" x))))
+
+(define (check-let env x)
   					; takes in the current environment and a scc
 					; returns new environment with scc's types added in
   (let* ([components (reverse (sccs (graph (let-bindings x))))]
@@ -166,6 +135,38 @@
 	 [new-env (fold-left process-component env components)])
     (check new-env (last (let-body x)))))
 
+(define (check env x)
+  (display "check: ")
+  (display x)
+  (display "\n\t")
+  (display env)
+  (newline)
+  (let
+      ((res
+	(case (ast-type x)
+	  ('int-literal (list '() 'Int))
+	  ('bool-literal (list '() 'Bool))
+	  ('string-literal (list '() 'String))
+	  ('builtin (list '() (builtin-type x)))
+
+	  ('if
+	   (let* ((cond-type-res (check env (cadr x)))
+		  (then-type-res (check env (caddr x)))
+		  (else-type-res (check env (cadddr x)))
+		  (then-eq-else-cs (~ (cadr then-type-res)
+				      (cadr else-type-res)))
+		  (cs (constraint-merge
+		       (car then-type-res)
+		       (constraint-merge (~ (cadr cond-type-res) 'Bool)
+					 (constraint-merge (car else-type-res)
+							   then-eq-else-cs))))
+		  (return-type (substitute cs (cadr then-type-res))))
+	     (list cs return-type)))
+	  
+	  ('var (list '() (env-lookup env x)))
+	  ('let (check-let env x))
+
+	  
 	  ('lambda
 	      (let* [(new-env (env-insert env (lambda-arg x) (fresh-tvar)))
 
@@ -226,18 +227,30 @@
 		     (let ((return-type (substitute cs (caddr resolved-func-type))))
 		       (list cs return-type))
 		     (error #f "not a function")))))))
-    ;; (display "result of ")
-    ;; (display x)
-    ;; (display ":\n\t")
-    ;; (display (pretty-type (cadr res)))
-    ;; (display "\n\t[")
-    ;; (display (pretty-constraints (car res)))
-    ;; (display "]\n")
+    (display "result of ")
+    (display x)
+    (display ":\n\t")
+    (display (pretty-type (cadr res)))
+    (display "\n\t[")
+    (display (pretty-constraints (car res)))
+    (display "]\n")
     res))
 
 					; we typecheck the lambda calculus only (only single arg lambdas)
 (define (typecheck prog)
-  (cadr (check '() (normalize prog))))
+  (define (constructor-type t ctr)
+    (fold-left (lambda (acc x) `(abs ,x ,acc)) t (cdr ctr)))
+  (define (constructors data-def)
+    (let ([type-name (cadr data-def)]
+	  [ctrs (cddr data-def)])
+    (fold-left (lambda (acc ctr)
+		 (cons (cons (car ctr) (constructor-type type-name ctr))
+		       acc))
+	       '()
+	       ctrs)))
+  (let ([init-env (flat-map constructors (program-datas prog))])
+    (display init-env)
+    (cadr (check init-env (normalize (program-body prog))))))
 
 					; returns a list of constraints
 (define (~ a b)
@@ -311,7 +324,7 @@
 
 
 ;; 					; a1 -> a2 ~ a3 -> a4;
-;; 					; a1 -> a2 !~ bool -> bool
+;; 					; a1 -> a2 !~ Bool -> Bool
 ;; 					; basically can the tvars be renamed
 (define (types-equal? x y)
   (let ([cs (unify? x y)])
-- 
2.30.2