Add typechecking pass

src/main/tock/compiler.cljc

@@ -2,7 +2,7 @@
   (:require [tock.compiler.desugar :refer [desugar]]
             [tock.compiler.bind :refer [bind]]
             [tock.compiler.specials :refer [specials]]
-            ;; [tock.compiler.type :refer [typecheck-expr]]
+            [tock.compiler.type :refer [typecheck]]
             ;; [tock.compiler.wasm :refer [ctx-to-wasm]]
             [meander.epsilon :as m]))
 
@@ -57,4 +57,5 @@
   (let [ctx (new-ctx)]
     (-> form
         (desugar specials)
-        (bind specials ctx))))
+        (bind specials ctx)
+        (typecheck specials))))

src/main/tock/compiler/bind.cljc

@@ -1,7 +1,7 @@
 (ns tock.compiler.bind
   (:require [meander.epsilon :as m]
             [tock.compiler.util :refer [get-special new-scope bind! lookup]]
-            [tock.compiler.meander :refer [bottom-up all-subexpressions m+ merge-metafield]]))
+            [tock.compiler.meander :refer [bottom-up all-subexpressions m+ merge-metafield] :include-macros true]))
 
 (defn decorate-ctx [specials ctx form]
   (let [special (get-special specials form)

src/main/tock/compiler/meander.cljc

@@ -9,7 +9,8 @@
     (list? form)   (apply list (first form) (merge (second form) m) (rest (rest form)))
     :else (do (print "m+ " form meta "\n") form)))
 
-(m/defsyntax m+ [meta-pattern pattern]
+(m/defsyntax m+ 
+  [meta-pattern pattern]
   (case (::r.syntax/phase &env)
     :meander/substitute `(m/app merge-metafield ~pattern ~meta-pattern)
     :meander/match      `(m/and (_ ~meta-pattern . _ ...) ~pattern)
@@ -48,4 +49,4 @@
 
 (defn bottom-up [s]
   (fn rec [t]
-    ((r/pipe s (all-subexpressions rec)) t)))
+    ((r/pipe (all-subexpressions rec) s) t)))

src/main/tock/compiler/specials.cljc

@@ -57,7 +57,7 @@
               ('l/fn (m/app merge ?m {:type ['fn . !types ... 'void]
                                       :params [!names ...]})
                      ('do {} & ?body)))
-    :typecheck (r/rewrite ({:type ['fn . _ ... ?return-type]} _) [[?return-type ?return-type]])
+    :typecheck (r/rewrite ({:type (m/and ?fn-type ['fn . _ ... ?return-type])} _) [[?fn-type ?return-type]])
     :scope {:local-counter 0 :valid-binding-forms #{'l/local 'l/param}}
     :new-bindings (fn [form _ctx]
                     (into {} (map-indexed (fn [index [name type]] [name (list 'l/param {:type type :name name :index index})])
@@ -89,10 +89,10 @@
    'do {:typecheck (r/rewrite (_) [['void]]
                               (_ . !stmt ... ?last) [[?last . (m/app (constantly 'void) !stmt) ... ?last]])
         :scope {}}
-   'l/lookup {:typecheck (r/rewrite ({:type ?type}) [[?type]])}
+   'l/lookup {}
-   'l/local {:typecheck (r/rewrite ({:type ?type}) [[?type]])}
+   'l/local {}
-   'l/param {:typecheck (r/rewrite ({:type ?type}) [[?type]])}
+   'l/param {}
-   'l/lit {:typecheck (r/rewrite ({:type ?type}) [[?type]])}
+   'l/lit {}
    'l/call 
    {:typecheck (r/rewrite (_ (m/and ['fn . !param-types ... ?return-type] ?fn-type) . _ ...)
                           [[?return-type ?fn-type . !param-types ...]])}

src/main/tock/compiler/type.cljc

@@ -1,39 +1,59 @@
 (ns tock.compiler.type
   (:require [meander.epsilon :as m]
-            [tock.compiler.util :refer [bind! compile-error lookup new-scope] :as u]))
+            [meander.strategy.epsilon :as r]
-
+            [tock.compiler.meander :refer [bottom-up m+] :include-macros true]
-; once we've hit the typechecking stage, nodes in our expression tree are maps, where each node has at least :special 
+            [tock.compiler.util :refer [lookup get-meta get-special lookup update-binding!]]))
-; and :args keys. :special is a symbol corresponding to a record in the `specials` map; :args is an ordered list of 
-; subexpressions. a node may optionally contain a :type field as well.
 
 ; typechecking happens bottom-up. by the time a node is called to be typechecked, the system has verified that all of the children
 ; under :args will have a :type field. 
 
-; there are two type syntaxes:
+; desugared type syntax is either a bare symbol (ie. 'void, 'i64), or for parameterized types, a dynamic variant stored as a vector
+; (ie ['fn arg-type arg-type return-type]).
 
-; 1. internal syntax - always stored in a form's metadata under the :type key. fetched with `expr-type`, added by
+; each special has an associated typechecking function, under the :typecheck key. This function is passed a list, where the first
-;                      `decorate-type`. generally is either a bare symbol, or for parameterized types, a dynamic 
+; element is the metadata map for the special, and the following elements are the types of the subexpression. It must return a
-;                       variant stored as a vector, like ['fn type type type].
+; vector of possible valid typings for the expression. A typing is a vector where the first element is the type of the parent
+; expression, and each subsequent element corresponds to a type that the corresponding subexpression should be coerced to.
 
-; 2. input syntax - stored in metadata with ^{} prefix syntax. converted to tock's internal syntax with `syntax-type`.
+; if no :typecheck key is specified, it is assumed that there are no subexpressions and the type should already be present in
-;                   generally, type names are stored as {:tag 'name}, and parameterized types like ['enum ...] are
+; the metadata, or that the form is a binding lookup and the type can be read from context
-;                   written in the input as ^{enum [...]}. (if there is only one parameter, the vector is skipped).
+(def default-typechecker 
-;                   The desugaring process handles this conversion.
+  (r/rewrite 
+   ({:ctx ?ctx :name ?name}) [[(m/app #(get-meta (lookup %1 %2) :type) ?ctx ?name)]]
+   ({:type ?type}) [[?type]]))
 
-;; built-in types
+(defn coerce [expr to-type]
+  (m/rewrite [(get-meta expr :type) to-type]
+             [?t ?t] ~expr
+             [_ 'void] ('l/cast {:type 'void} ~expr)
+             _ (m+ {:type-mismatch ~to-type} ~expr)))
 
-;; (defn make-type [symbol] (fn [expr] (assoc-type expr symbol)))
+(defn coerce-form [form typing]
-;; (def void (make-type 'void))
+  (m/rewrite [form typing]
-;; (def f64 (make-type 'f64))
+             [(?special ?m . !subexprs ...) [?result-type . !types ...]]
-;; (def bool (make-type 'bool))
+             (?special {:type ?result-type & ?m} . (m/app coerce !subexprs !types) ...)))
 
-;; typechecking helpers
+(defn typecheck-expr [form specials]
-(defn coerce [expr typesym error]
+  (let [special (get-special specials form)
-  (let [ltype (expr-type expr)]
+        typechecker (or (:typecheck special) default-typechecker)
-    (cond (= ltype typesym) expr
+        input (m/rewrite form (_ ?m . (m/and (_ {:type !subtype} . _ ...) _) ...) (?m . !subtype ...))
-          (= typesym 'void) (void `(u/cast-void ~expr))
+        _ (print (first form) input)
-          :else (throw error))))
+        typings (typechecker input)
+        rewrites (map #(coerce-form form %) typings)
+        valid-rewrites (filter #(nil? (get-meta % :type-mismatch)) rewrites)
+        rewrite (or (first valid-rewrites) (first rewrites))]
     
+    ; propogate type back to binding
+    (m/match rewrite
+      (m+ {:ctx ?ctx :name ?name :type ?type} _)
+      (update-binding! ?ctx ?name assoc :type ?type)
+
+      _ nil)
+    
+    rewrite))
+
+(defn typecheck [form specials] 
+  ((bottom-up #(typecheck-expr % specials)) form))
 
 ;; The typechecker itself!
 ;; This is currently doing several jobs at once:
@@ -52,28 +72,28 @@
 ;; External syntax uses simple namespaceless 'symbols, internal syntax uses `u/symbols
 
 ; todo: actually validate types
-(defn validate-type [type] type)
+;; (defn validate-type [type] type)
 
-; (fn [^type name ^type name -> return-type] body)
+;; ; (fn [^type name ^type name -> return-type] body)
-(defn alloc-local [ctx]
+;; (defn alloc-local [ctx]
-  (swap! (lookup ctx ::u/lastlocal) inc))
+;;   (swap! (lookup ctx ::u/lastlocal) inc))
 
-; todo: must store function metadata globally
+;; ; todo: must store function metadata globally
-(defn alloc-func [ctx func-type func-body]
+;; (defn alloc-func [ctx func-type func-body]
-  (let [funcs (swap! (lookup ctx ::u/module-funcs)
+;;   (let [funcs (swap! (lookup ctx ::u/module-funcs)
-                     (fn [funcs]
+;;                      (fn [funcs]
-                       (conj funcs {:type func-type :body func-body})))]
+;;                        (conj funcs {:type func-type :body func-body})))]
-    (- (count funcs) 1)))
+;;     (- (count funcs) 1)))
 
-(defn bind-params! [params ctx]
+;; (defn bind-params! [params ctx]
-  (let [bind-param! (fn [name type]
+;;   (let [bind-param! (fn [name type]
-                      (bind! ctx name {:local (alloc-local ctx)
+;;                       (bind! ctx name {:local (alloc-local ctx)
-                                       :type (validate-type type)}))
+;;                                        :type (validate-type type)}))
-        bind-all!   (fn [names return-type]
+;;         bind-all!   (fn [names return-type]
-                      (doseq [name names] (bind-param! name (syntax-type (meta name) ctx (compile-error name "Expected explicit type"))))
+;;                       (doseq [name names] (bind-param! name (syntax-type (meta name) ctx (compile-error name "Expected explicit type"))))
-                      (apply vector (concat ['fn]
+;;                       (apply vector (concat ['fn]
-                                            (map #(syntax-type (meta %) ctx nil) names)
+;;                                             (map #(syntax-type (meta %) ctx nil) names)
-                                            [(syntax-type return-type ctx (compile-error return-type "Invalid return type"))])))]
+;;                                             [(syntax-type return-type ctx (compile-error return-type "Invalid return type"))])))]
-    (m/match params
+;;     (m/match params
-      [!name ... '-> ?return-type] (bind-all! !name ?return-type)
+;;       [!name ... '-> ?return-type] (bind-all! !name ?return-type)
-      [!name ...] (bind-all! !name 'void))))
+;;       [!name ...] (bind-all! !name 'void))))