Switch to using type schemes and implement polymorphism in compiler series

code/compiler/10/ast.cpp

@@ -36,7 +36,7 @@ void ast_lid::find_free(type_mgr& mgr, type_env_ptr& env, std::set<std::string>&
 }
 
 type_ptr ast_lid::typecheck(type_mgr& mgr) {
-    return env->lookup(id);
+    return env->lookup(id)->instantiate(mgr);
 }
 
 void ast_lid::compile(const env_ptr& env, std::vector<instruction_ptr>& into) const {
@@ -56,7 +56,7 @@ void ast_uid::find_free(type_mgr& mgr, type_env_ptr& env, std::set<std::string>&
 }
 
 type_ptr ast_uid::typecheck(type_mgr& mgr) {
-    return env->lookup(id);
+    return env->lookup(id)->instantiate(mgr);
 }
 
 void ast_uid::compile(const env_ptr& env, std::vector<instruction_ptr>& into) const {
@@ -79,7 +79,7 @@ void ast_binop::find_free(type_mgr& mgr, type_env_ptr& env, std::set<std::string
 type_ptr ast_binop::typecheck(type_mgr& mgr) {
     type_ptr ltype = left->typecheck(mgr);
     type_ptr rtype = right->typecheck(mgr);
-    type_ptr ftype = env->lookup(op_name(op));
+    type_ptr ftype = env->lookup(op_name(op))->instantiate(mgr);
     if(!ftype) throw type_error(std::string("unknown binary operator ") + op_name(op));
 
     type_ptr return_type = mgr.new_type();
@@ -232,7 +232,7 @@ void pattern_var::insert_bindings(type_mgr& mgr, type_env_ptr& env) const {
 }
 
 void pattern_var::typecheck(type_ptr t, type_mgr& mgr, type_env_ptr& env) const {
-    mgr.unify(env->lookup(var), t);
+    mgr.unify(env->lookup(var)->instantiate(mgr), t);
 }
 
 void pattern_constr::print(std::ostream& to) const {
@@ -249,7 +249,7 @@ void pattern_constr::insert_bindings(type_mgr& mgr, type_env_ptr& env) const {
 }
 
 void pattern_constr::typecheck(type_ptr t, type_mgr& mgr, type_env_ptr& env) const {
-    type_ptr constructor_type = env->lookup(constr);
+    type_ptr constructor_type = env->lookup(constr)->instantiate(mgr);
     if(!constructor_type) {
         throw type_error(std::string("pattern using unknown constructor ") + constr);
     }
@@ -258,7 +258,7 @@ void pattern_constr::typecheck(type_ptr t, type_mgr& mgr, type_env_ptr& env) con
         type_arr* arr = dynamic_cast<type_arr*>(constructor_type.get());
         if(!arr) throw type_error("too many parameters in constructor pattern");
 
-        mgr.unify(env->lookup(param), arr->left);
+        mgr.unify(env->lookup(param)->instantiate(mgr), arr->left);
         constructor_type = arr->right;
     }
 

code/compiler/10/main.cpp

@@ -68,6 +68,7 @@ void typecheck_program(
         for(auto& def_defnn_name : group->members) {
             auto& def_defn = defs_defn.find(def_defnn_name)->second;
             def_defn->typecheck(mgr);
+            env->generalize(def_defnn_name, mgr);
         }
     }
 

code/compiler/10/type.cpp

@@ -1,8 +1,45 @@
 #include "type.hpp"
+#include <ostream>
 #include <sstream>
 #include <algorithm>
 #include "error.hpp"
 
+void type_scheme::print(const type_mgr& mgr, std::ostream& to) const {
+    if(forall.size() != 0) {
+        to << "forall ";
+        for(auto& var : forall) {
+            to << var << " ";
+        }
+        to << ". ";
+    }
+    monotype->print(mgr, to);
+}
+
+type_ptr substitute(const type_mgr& mgr, const std::map<std::string, type_ptr>& subst, const type_ptr& t) {
+    type_var* var;
+    type_ptr resolved = mgr.resolve(t, var);
+    if(var) {
+        auto subst_it = subst.find(var->name);
+        if(subst_it == subst.end()) return resolved;
+        return subst_it->second;
+    } else if(type_arr* arr = dynamic_cast<type_arr*>(t.get())) {
+        auto left_result = substitute(mgr, subst, arr->left);
+        auto right_result = substitute(mgr, subst, arr->right);
+        if(left_result == arr->left && right_result == arr->right) return t;
+        return type_ptr(new type_arr(left_result, right_result));
+    }
+    return t;
+}
+
+type_ptr type_scheme::instantiate(type_mgr& mgr) const {
+    if(forall.size() == 0) return monotype;
+    std::map<std::string, type_ptr> subst;
+    for(auto& var : forall) {
+        subst[var] = mgr.new_type();
+    }
+    return substitute(mgr, subst, monotype);
+}
+
 void type_var::print(const type_mgr& mgr, std::ostream& to) const {
     auto it = mgr.types.find(name);
     if(it != mgr.types.end()) {
@@ -97,3 +134,15 @@ void type_mgr::bind(const std::string& s, type_ptr t) {
     if(other && other->name == s) return;
     types[s] = t;
 }
+
+void type_mgr::find_free(const type_ptr& t, std::set<std::string>& into) const {
+    type_var* var;
+    type_ptr resolved = resolve(t, var);
+
+    if(var) {
+        into.insert(var->name);
+    } else if(type_arr* arr = dynamic_cast<type_arr*>(resolved.get())) {
+        find_free(arr->left, into);
+        find_free(arr->right, into);
+    }
+}

code/compiler/10/type.hpp

@@ -1,6 +1,8 @@
 #pragma once
 #include <memory>
 #include <map>
+#include <vector>
+#include <set>
 
 struct type_mgr;
 
@@ -12,6 +14,18 @@ struct type {
 
 using type_ptr = std::shared_ptr<type>;
 
+struct type_scheme {
+    std::vector<std::string> forall;
+    type_ptr monotype;
+
+    type_scheme(type_ptr type) : forall(), monotype(std::move(type)) {}
+
+    void print(const type_mgr& mgr, std::ostream& to) const;
+    type_ptr instantiate(type_mgr& mgr) const;
+};
+
+using type_scheme_ptr = std::shared_ptr<type_scheme>;
+
 struct type_var : public type {
     std::string name;
 
@@ -62,4 +76,5 @@ struct type_mgr {
     void unify(type_ptr l, type_ptr r);
     type_ptr resolve(type_ptr t, type_var*& var) const;
     void bind(const std::string& s, type_ptr t);
+    void find_free(const type_ptr& t, std::set<std::string>& into) const;
 };

code/compiler/10/type_env.cpp

@@ -1,6 +1,7 @@
 #include "type_env.hpp"
+#include "type.hpp"
 
-type_ptr type_env::lookup(const std::string& name) const {
+type_scheme_ptr type_env::lookup(const std::string& name) const {
     auto it = names.find(name);
     if(it != names.end()) return it->second;
     if(parent) return parent->lookup(name);
@@ -8,9 +9,25 @@ type_ptr type_env::lookup(const std::string& name) const {
 }
 
 void type_env::bind(const std::string& name, type_ptr t) {
+    names[name] = type_scheme_ptr(new type_scheme(t));
+}
+
+void type_env::bind(const std::string& name, type_scheme_ptr t) {
     names[name] = t;
 }
 
+void type_env::generalize(const std::string& name, type_mgr& mgr) {
+    auto names_it = names.find(name);
+    if(names_it == names.end()) throw 0;
+    if(names_it->second->forall.size() > 0) throw 0;
+
+    std::set<std::string> free_variables;
+    mgr.find_free(names_it->second->monotype, free_variables);
+    for(auto& free : free_variables) {
+        names_it->second->forall.push_back(free);
+    }
+}
+
 type_env_ptr type_scope(type_env_ptr parent) {
     return type_env_ptr(new type_env(std::move(parent)));
 }

code/compiler/10/type_env.hpp

@@ -7,13 +7,15 @@ using type_env_ptr = std::shared_ptr<type_env>;
 
 struct type_env {
     type_env_ptr parent;
-    std::map<std::string, type_ptr> names;
+    std::map<std::string, type_scheme_ptr> names;
 
     type_env(type_env_ptr p) : parent(std::move(p)) {}
     type_env() : type_env(nullptr) {}
 
-    type_ptr lookup(const std::string& name) const;
+    type_scheme_ptr lookup(const std::string& name) const;
     void bind(const std::string& name, type_ptr t);
+    void bind(const std::string& name, type_scheme_ptr t);
+    void generalize(const std::string& name, type_mgr& mgr);
 };