From 6c6d674c2a46d18d383f2bafa0325337ff702ddf Mon Sep 17 00:00:00 2001
From: Jeremy Penner <jeremy@sporktania.com>
Date: Mon, 22 Jul 2024 22:36:51 -0400
Subject: [PATCH] changed my mind; desugar expressions into (special metadata
 subexpr...)

started adding typechecking logic; still need to reimplement
typechecking pass itself
---
 src/main/tock/compiler/desugar.cljc  |  72 +++++++++----------
 src/main/tock/compiler/meander.cljc  |  44 ++++++++----
 src/main/tock/compiler/specials.cljc | 104 +++++++++++++++++----------
 src/main/tock/compiler/type.cljc     |   8 +++
 4 files changed, 137 insertions(+), 91 deletions(-)

diff --git a/src/main/tock/compiler/desugar.cljc b/src/main/tock/compiler/desugar.cljc
index bbf78fd..d9a7453 100644
--- a/src/main/tock/compiler/desugar.cljc
+++ b/src/main/tock/compiler/desugar.cljc
@@ -2,60 +2,56 @@
   (:require [meander.epsilon :as m]
             [meander.strategy.epsilon :as r]
             [tock.compiler.specials :refer [specials]]
-            [tock.compiler.meander :refer [meta-split typed label preserving-meta]]))
+            [tock.compiler.meander :refer [parse-type to-sym label] :include-macros true]))
 
 (def leaf-pass
-  (r/bottom-up 
-   (preserving-meta
+  (r/pipe
+   ;; all symbols must have their namespaces stripped!
+   (r/bottom-up
     (r/attempt
      (r/rewrite
-      (m/pred symbol? ?sym)  (m/app #(symbol (name %)) ?sym)
-      (m/pred integer? ?num) (typed (l/lit ?num) 'i64)
-      (m/pred double? ?num)  (typed (l/lit ?num) 'f64)
-      (m/pred boolean? ?b)   (typed (l/lit ?b) 'bool))))))
-
-(def type-cleanup-pass
-  (r/bottom-up 
-   (r/attempt
-    (r/rewrite
-     (meta-split {:tag (m/some ?symbol)} ?form)
-     (typed ?form (m/app #(symbol (name %)) ?symbol))
-
-     (meta-split {:fn [!type ... '-> ?return-type]} ?form)
-     (typed ?form ['fn . !type ... ?return-type])
-
-     (meta-split {:fn [!type ...]} ?form)
-     (typed ?form ['fn . !type ... 'void])))))
+      (m/pred symbol? ?sym)
+      (m/app #(with-meta (to-sym %) (merge (meta %) {:form %})) ?sym))))
+   (r/rewrite
+    (m/pred integer? ?num) ('l/lit {:type 'i64 :value ?num :form ?num})
+    (m/pred double? ?num)  ('l/lit {:type 'f64 :value ?num :form ?num})
+    (m/pred boolean? ?b)   ('l/lit {:type 'bool :value ?b :form ?b})
+   
+    (m/and ((m/cata ?verb) . (m/cata !nouns) ...) (m/app meta ?m) ?f)
+    (?verb (m/app merge (m/app parse-type ?m) {:form ?f}) . !nouns ...)
+   
+      ; [vectors] and {maps} are _not_ expressions and are parsed by special form's desugaring only
+    ?syntax ?syntax)))
 
 (defn make-desugar-pass [specials]
-  (r/top-down
-   (r/until =
-    (preserving-meta
-     (apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))))))
+  (let [desugar-strat (apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))]
+    (r/until =
+             (r/rewrite
+              ((m/cata ?special) ?m . (m/cata !args) ...)
+              (m/app desugar-strat (?special ?m . !args ...))
+    
+              ?form ?form))))
 
-(defn make-structure-pass [specials]
+(defn make-call-pass [specials]
   (let [special? (fn [key] (and (symbol? key) (contains? specials key)))]
     (r/rewrite
-     (meta-split ?meta (m/pred symbol? ?sym))
-     (m/app merge ?meta {:special 'l/read :name ?sym})
+     (m/and (m/pred symbol? ?sym) (m/app meta ?m)) ('l/read {:symbol ?sym & ?m})
+
+     ((m/pred special? ?special) ?m . (m/cata !args) ...)
+     (?special ?m . !args ...)
     
-     (meta-split ?meta ('l/lit ?val))
-     (m/app merge ?meta {:special 'l/lit :val ?val})
-    
-     (meta-split ?meta ((m/pred special? ?special) . (m/cata !args) ...))
-     (m/app merge ?meta {:special ?special :args [!args ...]})
-    
-     (meta-split ?meta ((m/pred #(not (special? %)) (m/cata ?func)) . (m/cata !args) ...))
-     (m/app merge ?meta {:special 'l/call :args [(label ?func "function") . (label !args "argument") ...]}))))
+     ((m/cata ?func) ?m . (m/cata !args) ...)
+     ('l/call ?m (label ?func "function") . (label !args "argument") ...)
+     
+     ?unknown ('l/compile-error {:form ?unknown :error "Unrecognized form"}))))
 
 (defn desugar 
   ([form] (desugar form specials))
   ([form specials]
    (let [desugar-pass (make-desugar-pass specials)
-         structure-pass (make-structure-pass specials)]
+         call-pass (make-call-pass specials)]
      (-> form
          leaf-pass
-         type-cleanup-pass
          desugar-pass
-         structure-pass
+         call-pass
          ))))
diff --git a/src/main/tock/compiler/meander.cljc b/src/main/tock/compiler/meander.cljc
index 04a4112..d321327 100644
--- a/src/main/tock/compiler/meander.cljc
+++ b/src/main/tock/compiler/meander.cljc
@@ -1,25 +1,39 @@
 (ns tock.compiler.meander
-  (:require [meander.epsilon :as m] 
+  (:require [meander.epsilon :as m]
+            [meander.strategy.epsilon :as r]
             [meander.syntax.epsilon :as r.syntax]))
 
-(defn m+ [more-meta val]
-  (with-meta val (merge (meta val) more-meta)))
+(defn merge-metafield [form m] 
+  (cond 
+    (symbol? form) (with-meta form (merge (meta form) m))
+    (list? form)   (apply list (first form) (merge (second form) m) (rest (rest form)))
+    :else (do (print "m+ " form meta "\n") form)))
 
-(defn preserving-meta [strategy]
-  (fn [term]
-    (let [new-term (strategy term)]
-      (if (satisfies? #?(:clj clojure.lang.IObj :cljs IWithMeta) new-term)
-        (with-meta new-term (merge (meta term) (meta new-term)))
-        new-term))))
-
-(m/defsyntax meta-split [meta-pattern pattern]
+(m/defsyntax m+ [meta-pattern pattern]
   (case (::r.syntax/phase &env)
-    :meander/substitute `(m/app m+ ~meta-pattern ~pattern)
-    :meander/match      `(m/and (m/app meta ~meta-pattern) ~pattern)
+    :meander/substitute `(m/app merge-metafield ~pattern ~meta-pattern)
+    :meander/match      `(m/and (_ ~meta-pattern . _ ...) ~pattern)
     &form))
 
 (m/defsyntax label [form label]
-  `(meta-split {:label ~label} ~form))
+  `(m+ {:label ~label} ~form))
 
 (m/defsyntax typed [form type]
-  `(meta-split {:type ~type} ~form))
+  `(m+ {:type ~type} ~form))
+
+(defn to-sym [ns-sym] (symbol (name ns-sym)))
+
+(def parse-type
+  (r/attempt
+   (r/rewrite
+    (m/pred symbol? ?symbol)
+    (m/app merge (m/app meta ?symbol) {:type ?symbol})
+
+    {:tag (m/some ?symbol) & ?m}
+    {:type (m/app to-sym ?symbol) & ?m}
+
+    {(m/app to-sym 'fn) [!type ... (m/app to-sym '->) ?return-type] & ?m}
+    {:type ['fn . !type ... ?return-type] & ?m}
+
+    {(m/app to-sym 'fn) [!type ...] & ?m}
+    {:type ['fn . !type ... 'void] & ?m})))
\ No newline at end of file
diff --git a/src/main/tock/compiler/specials.cljc b/src/main/tock/compiler/specials.cljc
index 300abf4..1c0fdbf 100644
--- a/src/main/tock/compiler/specials.cljc
+++ b/src/main/tock/compiler/specials.cljc
@@ -1,7 +1,7 @@
 (ns tock.compiler.specials
   (:require [meander.epsilon :as m]
             [meander.strategy.epsilon :as r]
-            [tock.compiler.meander :refer [meta-split label typed]]))
+            [tock.compiler.meander :refer [parse-type to-sym label] :include-macros true]))
 
 ;; no namespace - source symbol
 ;; l/sym - "lowered" form - special form not directly writable from source
@@ -9,52 +9,80 @@
 ;;         lowered form
 (defn left-associative  [symbol] 
   (r/rewrite
-   (~symbol ?left ?right . !more ..1) (~symbol (~symbol ?left ?right) !more ...)))
+   (~symbol ?m ?left ?right . !more ..1) (~symbol {} (~symbol ?m ?left ?right) !more ...)))
 
 (defn simple-identity [symbol]
-  (r/rewrite (~symbol ?v) ?v))
+  (r/rewrite (~symbol _ ?v) ?v))
 
 (defn left-binop-desugar [symbol]
   (r/choice (left-associative symbol) (simple-identity symbol)))
 
+(defn equatable-type? [typesym] (contains? #{'f64 'i32 'bool} typesym))
+(defn ordered-type? [typesym] (= typesym 'f64))
+(defn logical-type? [typesym] (= typesym 'bool))
+(defn numerical-type? [typesym] (= typesym 'f64))
+
+(defn combinator-typecheck [valid?]
+  (r/rewrite (_ (m/pred valid? ?l) (m/pred valid? ?r)) [[?l ?l ?l] [?r ?r ?r]]))
+
+(defn comparitor-typecheck [valid?]
+  (r/rewrite (_ (m/pred valid? ?l) (m/pred valid? ?r)) [['bool ?l ?l] ['bool ?r ?r]]))
+
 (def specials
   {'l/if
    {:desugar (r/rewrite
-              ('if ?cond ?body & ?more) (i/if ?cond ?body & ?more)
-              (i/if) ('do)
-              (i/if ?else) (label ?else "else block")
-              (i/if ?cond ?body & ?more) (l/if (label ?cond "condition")
-                                           (label ?body "body")
-                                           (i/if & ?more)))
-    :validate (r/rewrite ('if) "if statement needs at least a condition and a body"
-                         ('if _) "if statement needs at least one body expression")}
+              ('if ?m ?cond ?body & ?more) ('i/if ?m ?cond ?body & ?more)
+              ('i/if ?m) ('do ?m)
+              ('i/if _ ?else) (label ?else "else block")
+              ('i/if ?m ?cond ?body & ?more) ('l/if ?m (label ?cond "condition")
+                                                  (label ?body "body")
+                                                  ('i/if {} & ?more)))
+    :validate (r/rewrite ('if _) "if statement needs at least a condition and a body"
+                         ('if _ _) "if statement needs at least one body expression")
+    :typecheck (r/rewrite (_ ?cond ?l ?r) [[?l 'bool ?l ?l] [?r 'bool ?r ?r] ['void 'bool 'void 'void]])}
    
    'l/fn
    {:desugar (r/rewrite
-              ('fn (m/pred symbol? ?name) & ?rest)        (meta-split {:name ?name} ('def ('fn & ?rest)))
-              ('fn [!names ... '-> ?return-type] & ?body) (i/fn [!names ... (label ?return-type "return type")] & ?body)
-              ('fn [!names ...] & ?body)                  (i/fn [!names ... 'void] & ?body)
-             
-              ('i/fn [(typed !names !types) ... ?return-type] & ?body)
-              (meta-split {:type ['fn . !types ... ?return-type]
-                           :params [!names ...]}
-                          ('l/fn ('do & ?body))))}
-   '+ {:desugar (left-binop-desugar '+)} 
-   '- 
-   {:desugar (r/choice
-              (r/rewrite ('- ?v) ('- 0 ?v))
-              (left-associative '-))}
-   '* {:desugar (left-binop-desugar '*)} 
-   '/ {:desugar (left-binop-desugar '/)}
-   '= {}
-   'not= {}
-   '< {}
-   '<= {}
-   '> {}
-   '>= {}
-   'and {:desugar (left-binop-desugar 'and)} 
-   'or {:desugar (left-binop-desugar 'or)}
-   'def {}
-   'do {}
-   'l/lit {}
-   'l/call {}})
+              ('fn {& ?m} (m/pred symbol? ?name) & ?rest)     
+              ('def {:name ?name} ('fn {:name ?name & ?m} & ?rest))
+
+              ('fn {& ?m} [(m/app (fn [params] [params (parse-type (meta params))]) [(m/pred symbol? !names) {:type !types}]) ...
+                           (m/app to-sym '->) (m/app parse-type {:type !types})] & ?body)
+              ('l/fn (m/app merge ?m {:type ['fn . !types ...]
+                                      :params [!names ...]})
+                ('do {} & ?body))
+              
+              ('fn {& ?m} [(m/app (fn [params] [params (parse-type (meta params))]) [(m/pred symbol? !names) {:type !types}]) ...] & ?body)
+              ('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]])}
+   '+ {:desugar (left-binop-desugar '+)
+       :typecheck (combinator-typecheck numerical-type?)} 
+   '- {:desugar (r/choice
+                 (r/rewrite ('- ?m ?v) ('- ?m 0 ?v))
+                 (left-associative '-))
+       :typecheck (combinator-typecheck numerical-type?)}
+   '* {:desugar (left-binop-desugar '*)
+       :typecheck (combinator-typecheck numerical-type?)} 
+   '/ {:desugar (left-binop-desugar '/)
+       :typecheck (combinator-typecheck numerical-type?)}
+   '= {:typecheck (comparitor-typecheck equatable-type?)}
+   'not= {:typecheck (comparitor-typecheck equatable-type?)}
+   '< {:typecheck (comparitor-typecheck ordered-type?)}
+   '<= {:typecheck (comparitor-typecheck ordered-type?)}
+   '> {:typecheck (comparitor-typecheck ordered-type?)}
+   '>= {:typecheck (comparitor-typecheck ordered-type?)}
+   'and {:desugar (left-binop-desugar 'and)
+         :typecheck (comparitor-typecheck logical-type?)}
+   'or {:desugar (left-binop-desugar 'or)
+        :typecheck (comparitor-typecheck logical-type?)}
+   'def {:typecheck (r/rewrite (_ ?t) [[?t ?t]])}
+   'do {:typecheck (r/rewrite (_) [['void]]
+                              (_ . !stmt ... ?last) [[?last . (m/app (constantly 'void) !stmt) ... ?last]])}
+   'l/read {:typecheck (r/rewrite ({:type ?type}) [[?type]])}
+   'l/lit {:typecheck (r/rewrite ({:type ?type}) [[?type]])}
+   'l/call 
+   {:typecheck (r/rewrite (_ (m/and ['fn . !param-types ... ?return-type] ?fn-type) . _ ...)
+                          [[?return-type ?fn-type . !param-types ...]])}
+   })
diff --git a/src/main/tock/compiler/type.cljc b/src/main/tock/compiler/type.cljc
index 9892204..78e5fc1 100644
--- a/src/main/tock/compiler/type.cljc
+++ b/src/main/tock/compiler/type.cljc
@@ -2,6 +2,13 @@
   (:require [meander.epsilon :as m]
             [tock.compiler.util :refer [bind! compile-error form-dispatch lookup map-subexpressions new-scope] :as u]))
 
+; once we've hit the typechecking stage, nodes in our expression tree are maps, where each node has at least :special 
+; 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:
 
 ; 1. internal syntax - always stored in a form's metadata under the :type key. fetched with `expr-type`, added by
@@ -11,6 +18,7 @@
 ; 2. input syntax - stored in metadata with ^{} prefix syntax. converted to tock's internal syntax with `syntax-type`.
 ;                   generally, type names are stored as {:tag 'name}, and parameterized types like ['enum ...] are
 ;                   written in the input as ^{enum [...]}. (if there is only one parameter, the vector is skipped).
+;                   The desugaring process handles this conversion.
 
 (defn syntax-type [metadata _ctx error]
   (m/match metadata