Move specials to a lookup table, add call + read pass

src/main/tock/compiler/desugar.cljc

@@ -1,21 +1,8 @@
 (ns tock.compiler.desugar
   (:require [meander.epsilon :as m]
             [meander.strategy.epsilon :as r]
-            [tock.compiler.meander :refer [meta-split label typed m+]]))
+            [tock.compiler.specials :refer [specials]]
-
+            [tock.compiler.meander :refer [meta-split typed label preserving-meta]]))
-;; desugaring idea:
-;; - each parameter to a special is decorated with a human-readable descriptor
-;;   as well as the original syntax object it corresponds to
-
-(defn preserving-meta [strategy]
-  (fn [term]
-    (let [new-term (strategy term)]
-      (m+ (merge (meta new-term) (meta term)) new-term))))
-
-;; no namespace - source symbol
-;; l/sym - "lowered" form - special form not directly writable from source
-;; i/sym - intermediate symbol meant to be recursively expanded into a canonical
-;;         lowered form
 
 (def leaf-pass
   (r/bottom-up 
@@ -34,41 +21,41 @@
      (typed ?form ?symbol)
 
      (meta-split {:fn [!type ... '-> ?return-type]} ?form)
-     (typed ?form ['fn !type ... ?return-type])
+     (typed ?form ['fn . !type ... ?return-type])
 
      (meta-split {:fn [!type ...]} ?form)
-     (typed ?form ['fn !type ... 'void])))))
+     (typed ?form ['fn . !type ... 'void])))))
 
-(defn make-desugar-pass [sugars]
+(defn make-desugar-pass [specials]
   (r/top-down
    (r/until =
     (preserving-meta
-     (apply r/pipe (map r/attempt sugars))))))
+     (apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))))))
 
-(def tock-sugars
+(defn make-lookup-pass [specials] 
-  [(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)))
   (r/rewrite
-    ('fn (m/pred symbol? ?name) & ?rest)        ('def ?name ('fn & ?rest))
+   (meta-split ?meta (m/pred symbol? ?sym)) 
-    ('fn [!names ... '-> ?return-type] & ?body) (l/fn [!names ... (label ?return-type "return type")] & ?body)
+   (meta-split ?meta ('l/read ?sym))
-    ('fn [!names ...] & ?body)                  (l/fn [!names ... 'void] & ?body))
-   ])
 
-(def tock-parse-errors
+   (meta-split ?meta
-  [(r/rewrite ('if) "if statement needs at least a condition and a body"
+               ((m/pred #(and (symbol? %) (get-in specials [% :leaf])) ?special) . !args ...))
-              ('if _) "if statement needs at least one body expression")
+   (meta-split ?meta (?special . !args ...))
-   ])
+
+   (meta-split ?meta
+               ((m/pred #(and (symbol? %) (contains? specials %)) ?special) . (m/cata !args) ...))
+   (meta-split ?meta (?special . !args ...))
+
+   (meta-split ?meta
+               ((m/pred #(or (not (symbol? %)) (not (contains? specials %))) (m/cata ?head)) . (m/cata !args) ...))
+   (meta-split ?meta ('l/call (label ?head "function") . (label !args "argument") ...))))
 
 (defn desugar 
-  ([form] (desugar form tock-sugars))
+  ([form] (desugar form specials))
-  ([form sugars]
+  ([form specials]
-   (let [desugar-pass (make-desugar-pass sugars)]
+   (let [desugar-pass (make-desugar-pass specials)
+         lookup-pass (make-lookup-pass specials)]
      (-> form
          leaf-pass
          type-cleanup-pass
-         desugar-pass))))
+         desugar-pass
+         lookup-pass))))

src/main/tock/compiler/meander.cljc

@@ -3,9 +3,14 @@
             [meander.syntax.epsilon :as r.syntax]))
 
 (defn m+ [more-meta val]
-  (if (satisfies? #?(:clj clojure.lang.IObj :cljs IWithMeta) val)
+  (with-meta val (merge (meta val) more-meta)))
-    (with-meta val (merge (meta val) more-meta))
+
-    val))
+(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]
   (case (::r.syntax/phase &env)

src/main/tock/compiler/specials.cljc

@@ -0,0 +1,61 @@
+(ns tock.compiler.specials
+  (:require [meander.epsilon :as m]
+            [meander.strategy.epsilon :as r]
+            [tock.compiler.meander :refer [meta-split label typed]]))
+
+;; no namespace - source symbol
+;; l/sym - "lowered" form - special form not directly writable from source
+;; i/sym - intermediate symbol meant to be recursively expanded into a canonical
+;;         lowered form
+(defn left-associative  [symbol] 
+  (r/rewrite
+   (~symbol ?left ?right . !more ..1) (~symbol (~symbol ?left ?right) !more ...)))
+
+(defn simple-identity [symbol]
+  (r/rewrite (~symbol ?v) ?v))
+
+(defn left-binop-desugar [symbol]
+  (r/choice (left-associative symbol) (simple-identity symbol)))
+
+(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")}
+   
+   '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) ('- ('l/lit 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 {:leaf true}
+   'l/read {:leaf true}
+   'l/call {}})