diff --git a/src/main/tock/compiler/desugar.cljc b/src/main/tock/compiler/desugar.cljc index ab0d663..cc58b98 100644 --- a/src/main/tock/compiler/desugar.cljc +++ b/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+]])) - -;; 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 + [tock.compiler.specials :refer [specials]] + [tock.compiler.meander :refer [meta-split typed label preserving-meta]])) (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 - [(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)) - ('fn [!names ... '-> ?return-type] & ?body) (l/fn [!names ... (label ?return-type "return type")] & ?body) - ('fn [!names ...] & ?body) (l/fn [!names ... 'void] & ?body)) - ]) +(defn make-lookup-pass [specials] + (r/rewrite + (meta-split ?meta (m/pred symbol? ?sym)) + (meta-split ?meta ('l/read ?sym)) -(def tock-parse-errors - [(r/rewrite ('if) "if statement needs at least a condition and a body" - ('if _) "if statement needs at least one body expression") - ]) + (meta-split ?meta + ((m/pred #(and (symbol? %) (get-in specials [% :leaf])) ?special) . !args ...)) + (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 sugars] - (let [desugar-pass (make-desugar-pass sugars)] + ([form] (desugar form specials)) + ([form specials] + (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)))) diff --git a/src/main/tock/compiler/meander.cljc b/src/main/tock/compiler/meander.cljc index f87bd58..04a4112 100644 --- a/src/main/tock/compiler/meander.cljc +++ b/src/main/tock/compiler/meander.cljc @@ -2,10 +2,15 @@ (:require [meander.epsilon :as m] [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)) - val)) +(defn m+ [more-meta val] + (with-meta val (merge (meta val) more-meta))) + +(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) diff --git a/src/main/tock/compiler/specials.cljc b/src/main/tock/compiler/specials.cljc new file mode 100644 index 0000000..53f84fa --- /dev/null +++ b/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 {}})