changed my mind; desugar expressions into (special metadata subexpr...)
started adding typechecking logic; still need to reimplement typechecking pass itself
This commit is contained in:
parent
a362729acc
commit
6c6d674c2a
|
|
@ -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
|
||||
))))
|
||||
|
|
|
|||
|
|
@ -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})))
|
||||
|
|
@ -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 ...]])}
|
||||
})
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue