diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lux/analyser.clj | 401 | ||||
| -rw-r--r-- | src/lux/analyser/base.clj | 230 | ||||
| -rw-r--r-- | src/lux/analyser/case.clj | 380 | ||||
| -rw-r--r-- | src/lux/analyser/env.clj | 38 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 158 | ||||
| -rw-r--r-- | src/lux/analyser/lambda.clj | 22 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 277 | ||||
| -rw-r--r-- | src/lux/analyser/module.clj | 266 | ||||
| -rw-r--r-- | src/lux/analyser/record.clj | 122 |
9 files changed, 1028 insertions, 866 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 41a59fc00..8c88328f5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail* |case $$]] + (lux [base :as & :refer [|let |do return fail return* fail* |case]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -23,24 +23,24 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (|case token - [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] - (&/$Cons [_ (&/$TextS ?ex-class)] - (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] - (&/$Cons ?catch-body - (&/$Nil))))))] - (return (&/P (&/|++ catch+ (&/|list ($$ &/P ?ex-class ?ex-arg ?catch-body))) finally+)) - - [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] - (&/$Cons ?finally-body - (&/$Nil))))] - (return (&/P catch+ (&/Some$ ?finally-body))) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_catch")) + (&/$Cons (&/$Meta _ (&/$TextS ?ex-class)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ex-arg)) + (&/$Cons ?catch-body + (&/$Nil))))))) + (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) + + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_finally")) + (&/$Cons ?finally-body + (&/$Nil))))) + (return (&/T catch+ (&/V &/$Some ?finally-body))) _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private parse-tag [ast] (|case ast - [_ (&/$TagS "" name)] + (&/$Meta _ (&/$TagS "" name)) (return name) _ @@ -49,44 +49,44 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] - (&/$Cons [_ (&/$SymbolS _ ?class)] - (&/$Cons [_ (&/$IntS ?length)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) + (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) + (&/$Cons (&/$Meta _ (&/$IntS ?length)) (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TextS ?super-class)] - (&/$Cons [_ (&/$TupleS ?interfaces)] - (&/$Cons [_ (&/$TupleS ?fields)] - (&/$Cons [_ (&/$TupleS ?methods)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_class")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TextS ?super-class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?interfaces)) + (&/$Cons (&/$Meta _ (&/$TupleS ?fields)) + (&/$Cons (&/$Meta _ (&/$TupleS ?methods)) (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TupleS ?supers)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] - (&/$Cons [_ (&/$SymbolS "" ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) (&/$Cons ?body (&/$Nil))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -97,86 +97,86 @@ (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) _ @@ -185,106 +185,106 @@ (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Objects - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) (&/$Cons ?object (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")] - (&/$Cons [_ (&/$TextS ?class)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) (&/$Cons ?object (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TupleS ?classes)] - (&/$Cons [_ (&/$TupleS ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?object (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?value (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?object (&/$Cons ?value (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] - (&/$Cons [_ (&/$TupleS ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) (&/$Cons ?body ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/P (&/|list) &/None$) ?handlers)] + (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) (&/$Cons ?ex (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorexit")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) @@ -295,53 +295,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -351,63 +351,63 @@ (|case token ;; Host special forms ;; Characters - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ @@ -418,60 +418,60 @@ (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_case")) (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")] - (&/$Cons [_ (&/$SymbolS "" ?self)] - (&/$Cons [_ (&/$SymbolS "" ?arg)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) (&/$Cons ?body (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] - (&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] - (&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] - (&/$Cons [_ (&/$TupleS tags)] - (&/$Cons [_ (&/$SymbolS "" type-name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) + (&/$Cons (&/$Meta _ (&/$TupleS tags)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] (&&lux/analyse-declare-tags tags* type-name)) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] - (&/$Cons [_ (&/$TextS ?path)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) + (&/$Cons (&/$Meta _ (&/$TextS ?path)) (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] - (&/$Cons [_ (&/$SymbolS "" ?ident)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] - (&/$Cons [_ (&/$TextS ?alias)] - (&/$Cons [_ (&/$TextS ?module)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) + (&/$Cons (&/$Meta _ (&/$TextS ?alias)) + (&/$Cons (&/$Meta _ (&/$TextS ?module)) (&/$Nil))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) @@ -483,23 +483,23 @@ ;; Standard special forms (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/P (&/S &&/$bool ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$bool ?value) exo-type)))) (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/P (&/S &&/$int ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/P (&/S &&/$real ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/P (&/S &&/$char ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/P (&/S &&/$text ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) @@ -528,21 +528,20 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - [meta ?token] + (&/$Meta meta ?token) (fn [state] - (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - ;; (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - ;; (catch Error e - ;; (prn e) - ;; (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) + (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (catch Error e + (prn e) + (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) (&/$Right state* output) (return* state* output) (&/$Left "") - (fail* (add-loc (&/$get-cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) (&/$Left msg) - (fail* (add-loc (&/$get-cursor state) msg)) + (fail* (add-loc (&/get$ &/$cursor state) msg)) )) )) @@ -554,44 +553,42 @@ [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] - (return (&/P ?output-term ?output-type*))) - (return (&/P ?output-term ?output-type))) + (return (&/T ?output-term ?output-type*))) + (return (&/T ?output-term ?output-type))) [_ _] - (return (&/P ?output-term ?output-type))) + (return (&/T ?output-term ?output-type))) )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] - ;; (prn 'analyse-ast (&/adt->text token)) ;; (prn 'analyse-ast (&/show-ast token)) - (|let [[cursor _] token] - (&/with-cursor cursor - (&/with-expected-type exo-type - (|case token - [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) - - [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/P module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) - - [meta (&/$FormS (&/$Cons ?fn ?args))] - (fn [state] - (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - (&/$Right state* =fn) - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - - _ - ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - - _ - (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))))) + (&/with-cursor (aget token 1 0) + (&/with-expected-type exo-type + (|case token + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + + (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) + (fn [state] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + (&/$Right state* =fn) + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + + _ + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + _ + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 622f0b853..fe1e0d55b 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -13,120 +13,120 @@ [type :as &type]))) ;; [Tags] -(deftags - ["bool" - "int" - "real" - "char" - "text" - "unit" - "sum" - "prod" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - ]) +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) ;; [Exports] (defn expr-type [syntax+] @@ -147,4 +147,4 @@ (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] - (return (&/P module* ?name))))) + (return (&/T module* ?name))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6bb767d3e..483002adc 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -9,7 +9,7 @@ (ns lux.analyser.case (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |do return fail |let |case $$]] + (lux [base :as & :refer [deftags |do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -18,33 +18,31 @@ [record :as &&record]))) ;; [Tags] -(deftags - ["DefaultTotal" - "BoolTotal" - "IntTotal" - "RealTotal" - "CharTotal" - "TextTotal" - "UnitTotal" - "ProdTotal" - "SumTotal"] +(deftags "" + "DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "TupleTotal" + "VariantTotal" ) -(deftags - ["StoreTestAC" - "BoolTestAC" - "IntTestAC" - "RealTestAC" - "CharTestAC" - "TextTestAC" - "UnitTestAC" - "ProdTestAC" - "SumTestAC"] +(deftags "" + "StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "TupleTestAC" + "VariantTestAC" ) ;; [Utils] (def ^:private unit - (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS (&/|list)))) + (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) (defn ^:private resolve-type [type] (|case type @@ -66,229 +64,269 @@ _ (&type/actual-type type))) -(let [cleaner (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/S &/$BoundT _aarg))] - (&type/clean* _avar _abody))))] - (defn adjust-type* [up type] - "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" - ;; (prn 'adjust-type* (&type/show-type type)) - (|case type - (&/$AllT _aenv _aname _aarg _abody) - (&type/with-var - (fn [$var] - (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/Cons$ ($$ &/P _aenv _aname _aarg $var) up) =type)))) - - (&/$SumT ?left ?right) - (|do [=left (&/fold% cleaner ?left up) - =right (&/fold% cleaner ?right up)] - (return (&type/Sum$ =left =right))) - - (&/$ProdT ?left ?right) - (|do [=left (&/fold% cleaner ?left up) - =right (&/fold% cleaner ?right up)] - (return (&type/Prod$ =left =right))) - - (&/$AppT ?tfun ?targ) - (|do [=type (&type/apply-type ?tfun ?targ)] - (adjust-type* up =type)) - - (&/$VarT ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##9##")))] - (adjust-type* up type*)) - - (&/$NamedT ?name ?type) - (adjust-type* up ?type) - - _ - (assert false (prn 'adjust-type* (&type/show-type type))) - ))) +(defn adjust-type* [up type] + "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + ;; (prn 'adjust-type* (&type/show-type type)) + (|case type + (&/$AllT _aenv _aname _aarg _abody) + (&type/with-var + (fn [$var] + (|do [=type (&type/apply-type type $var)] + (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) + + (&/$TupleT ?members) + (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&type/Tuple$ (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$VariantT ?members) + (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$VariantT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$AppT ?tfun ?targ) + (|do [=type (&type/apply-type ?tfun ?targ)] + (adjust-type* up =type)) + + (&/$VarT ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##9##")))] + (adjust-type* up type*)) + + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + + _ + (assert false (prn 'adjust-type* (&type/show-type type))) + )) (defn adjust-type [type] "(-> Type (Lux Type))" (adjust-type* (&/|list) type)) -(defn ^:private resolve-tag [tag type] - (|do [[=module =name] (&&/resolved-ident tag) - type* (adjust-type type) - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) - ;; :let [_ (prn 'resolve-tag =module =name (&/adt->text group))] - case-type (&type/variant-case idx type*)] - (return ($$ &/P idx (&/|length group) case-type)))) - (defn ^:private analyse-pattern [value-type pattern kont] - (|let [[meta pattern*] pattern - ;; _ (prn 'analyse-pattern (&/show-ast pattern) (&type/show-type value-type)) - ] + (|let [(&/$Meta _ pattern*) pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/P (&/S $StoreTestAC idx) =kont))) + (return (&/T (&/V $StoreTestAC idx) =kont))) + + (&/$SymbolS ident) + (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/P (&/S $BoolTestAC ?value) =kont))) + (return (&/T (&/V $BoolTestAC ?value) =kont))) (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/P (&/S $IntTestAC ?value) =kont))) + (return (&/T (&/V $IntTestAC ?value) =kont))) (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/P (&/S $RealTestAC ?value) =kont))) + (return (&/T (&/V $RealTestAC ?value) =kont))) (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/P (&/S $CharTestAC ?value) =kont))) + (return (&/T (&/V $CharTestAC ?value) =kont))) (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/P (&/S $TextTestAC ?value) =kont))) + (return (&/T (&/V $TextTestAC ?value) =kont))) - (&/$TupleS (&/$Nil)) - (|do [_ (&type/check value-type &type/Unit) - =kont kont] - (return (&/P (&/S $UnitTestAC nil) =kont))) - - (&/$TupleS (&/$Cons ?_left ?tail)) + (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] + (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) + (|case value-type* + (&/$TupleT ?member-types) + (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont))))) + + _ + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) + + (&/$RecordS pairs) + (|do [?members (&&record/order-record pairs) + ;; :let [_ (prn 'PRE (&type/show-type value-type))] + value-type* (adjust-type value-type) + ;; :let [_ (prn 'POST (&type/show-type value-type*))] + ;; value-type* (resolve-type value-type) + ] (|case value-type* - (&/$ProdT ?left ?right) - (|do [[=left [=right =kont]] (analyse-pattern ?left ?_left - (|do [[=right =kont] (|case ?tail - (&/$Cons ?_right (&/$Nil)) - (analyse-pattern ?right ?_right kont) - - (&/$Nil) - (fail "[Pattern-matching Error] Pattern-matching mismatch. Tuple has wrong size.") - - _ - (analyse-pattern ?right (&/P meta (&/S &/$TupleS ?tail)) kont))] - (return (&/P =right =kont))))] - (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont))) + (&/$TupleT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont)))) _ - (fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*))))) - - (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs)] - (analyse-pattern value-type (&/P meta (&/S &/$TupleS ?members)) kont)) + (fail "[Pattern-matching Error] Record requires record-type."))) (&/$TagS ?ident) - (|do [[idx group-count case-type] (resolve-tag ?ident value-type) - [=test =kont] (analyse-pattern case-type unit kont)] - (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) - - (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) - (|do [[idx group-count case-type] (resolve-tag ?ident value-type) + (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#01")] + value-type* (adjust-type value-type) + ;; :let [_ (println "#02")] + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + ;; :let [_ (println "#03")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#04")] + [=test =kont] (analyse-pattern case-type unit kont) + ;; :let [_ (println "#05")] + ] + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + + (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) + ?values)) + (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#11")] + value-type* (adjust-type value-type) + ;; :let [_ (println "#12" (&type/show-type value-type*))] + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + ;; :let [_ (println "#13")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#14" (&type/show-type case-type))] [=test =kont] (case (&/|length ?values) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS ?values)) kont)) + (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) ;; :let [_ (println "#15")] ] - (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern (&&/analyse-1 analyse exo-type body))] - (return (&/Cons$ pattern+body patterns)))) + (return (&/|cons pattern+body patterns)))) (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] (|case [struct test] [($DefaultTotal total?) ($StoreTestAC ?idx)] - (return (&/S $DefaultTotal true)) + (return (&/V $DefaultTotal true)) [[?tag [total? ?values]] ($StoreTestAC ?idx)] - (return (&/S ?tag (&/P true ?values))) + (return (&/V ?tag (&/T true ?values))) [($DefaultTotal total?) ($BoolTestAC ?value)] - (return (&/S $BoolTotal (&/P total? (&/|list ?value)))) + (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/S $BoolTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($IntTestAC ?value)] - (return (&/S $IntTotal (&/P total? (&/|list ?value)))) + (return (&/V $IntTotal (&/T total? (&/|list ?value)))) [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/S $IntTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($RealTestAC ?value)] - (return (&/S $RealTotal (&/P total? (&/|list ?value)))) + (return (&/V $RealTotal (&/T total? (&/|list ?value)))) [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/S $RealTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($CharTestAC ?value)] - (return (&/S $CharTotal (&/P total? (&/|list ?value)))) + (return (&/V $CharTotal (&/T total? (&/|list ?value)))) [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/S $CharTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($TextTestAC ?value)] - (return (&/S $TextTotal (&/P total? (&/|list ?value)))) + (return (&/V $TextTotal (&/T total? (&/|list ?value)))) [($TextTotal total? ?values) ($TextTestAC ?value)] - (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values)))) - - [($DefaultTotal total?) ($UnitTestAC)] - (return (&/S $UnitTotal nil)) - - [($UnitTotal) ($UnitTestAC)] - (return (&/S $UnitTotal nil)) - - [($DefaultTotal total?) ($ProdTestAC ?left ?right)] - (|do [:let [_default (&/S $DefaultTotal total?)] - =left (merge-total _default (&/P ?left ?body)) - =right (merge-total _default (&/P ?right ?body))] - (return (&/S $ProdTotal ($$ &/P total? =left =right)))) - - [($ProdTotal total? ?_left ?_right) ($ProdTestAC ?left ?right)] - (|do [=left (merge-total ?_left (&/P ?left ?body)) - =right (merge-total ?_right (&/P ?right ?body))] - (return (&/S $ProdTotal ($$ &/P total? =left =right)))) - - [($DefaultTotal total?) ($SumTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (&/S $DefaultTotal total?) - (&/P ?test ?body)) - structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/S $DefaultTotal total?))) + (return (&/V $TextTotal (&/T total? (&/|cons ?value ?values)))) + + [($DefaultTotal total?) ($TupleTestAC ?tests)] + (|do [structs (&/map% (fn [t] + (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) + ?tests)] + (return (&/V $TupleTotal (&/T total? structs)))) + + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map2% (fn [v t] + (merge-total v (&/T t ?body))) + ?values ?tests)] + (return (&/V $TupleTotal (&/T total? structs)))) + (fail "[Pattern-matching Error] Inconsistent tuple-size.")) + + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (&/V $DefaultTotal total?) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/S $SumTotal (&/P total? structs)))) + (return (&/V $VariantTotal (&/T total? structs)))) - [($SumTotal total? ?branches) ($SumTestAC ?tag ?count ?test)] + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) (&/$Some sub) sub (&/$None) - (&/S $DefaultTotal total?)) - (&/P ?test ?body)) + (&/V $DefaultTotal total?)) + (&/T ?test ?body)) structs (|case (&/|list-put ?tag sub-struct ?branches) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/S $SumTotal (&/P total? structs)))) + (return (&/V $VariantTotal (&/T total? structs)))) )))) (defn ^:private check-totality [value-type struct] @@ -313,39 +351,33 @@ ($TextTotal ?total _) (return ?total) - ($UnitTotal) - (return true) - - ($ProdTotal ?total ?_left ?_right) + ($TupleTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$ProdT ?left ?right) - (|do [=left (check-totality ?left ?_left) - =right (check-totality ?right ?_right)] - (return (and =left =right))) + (&/$TupleT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) _ (fail "[Pattern-maching Error] Tuple is not total.")))) - ($SumTotal ?total ?structs) + ($VariantTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (|case [value-type* ?structs] - [(&/$SumT ?left ?right) (&/$Cons ?_left ?tail)] - (|do [=left (check-totality ?left ?_left) - =right (|case ?tail - (&/$Cons ?_right (&/$Nil)) - (check-totality ?right ?_right) - - (&/$Nil) - (fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.") - - _ - (check-totality ?right (&/S $SumTotal (&/P ?total ?tail))))] - (return (and =left =right))) + (|case value-type* + (&/$VariantT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + ;; (prn '$VariantTotal + ;; (&/adt->text sub-struct) + ;; (&type/show-type ?member)) + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) _ (fail "[Pattern-maching Error] Variant is not total.")))) @@ -362,7 +394,7 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - struct (&/fold% merge-total (&/S $DefaultTotal false) patterns) + struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) ? (check-totality value-type struct)] (if ? (return patterns) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 5686700e3..4e9dcd79f 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,31 +15,31 @@ ;; [Exports] (def next-local-idx (fn [state] - (return* state (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-counter))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] ;; (prn 'with-local name) - (let [old-mappings (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-mappings)) - =return (body (&/$update-envs - (fn [stack] - (let [bound-unit (&/S &&/$var (&/S &/$Local (->> (&/|head stack) (&/$get-locals) (&/$get-counter))))] - (&/Cons$ (&/$update-locals #(->> % - (&/$update-counter inc) - (&/$update-mappings (fn [m] (&/|put name (&/P bound-unit type) m)))) - (&/|head stack)) - (&/|tail stack)))) - state))] + (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$envs + (fn [stack] + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) + (&/|head stack)) + (&/|tail stack)))) + state))] (|case =return (&/$Right ?state ?value) - (return* (&/$update-envs (fn [stack*] - (&/Cons$ (&/$update-locals #(->> % - (&/$update-counter dec) - (&/$set-mappings old-mappings)) - (&/|head stack*)) - (&/|tail stack*))) - ?state) + (return* (&/update$ &/$envs (fn [stack*] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) ?value) _ @@ -47,4 +47,4 @@ (def captured-vars (fn [state] - (return* state (->> state (&/$get-envs) &/|head (&/$get-closure) (&/$get-mappings))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings))))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 69aa95f12..64f297994 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case $$]] + (lux [base :as & :refer [|let |do return fail |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -20,7 +20,7 @@ ;; [Utils] (defn ^:private extract-text [text] (|case text - [_ (&/$TextS ?text)] + (&/$Meta _ (&/$TextS ?text)) (return ?text) _ @@ -32,7 +32,7 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/P ?item =type)))))) + (return (&/T ?item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" @@ -47,20 +47,20 @@ "(-> Type Type)" (|case type (&/$DataT class) - (&type/Data$ (&type/as-obj class)) + (&/V &/$DataT (&type/as-obj class)) _ type)) ;; [Resources] (do-template [<name> <output-tag> <input-class> <output-class>] - (let [input-type (&type/Data$ <input-class>) - output-type (&type/Data$ <output-class>)] + (let [input-type (&/V &/$DataT <input-class>) + output-type (&/V &/$DataT <output-class>)] (defn <name> [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S <output-tag> (&/P =x =y)) output-type)))))) + (return (&/|list (&/T (&/V <output-tag> (&/T =x =y)) output-type)))))) analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" @@ -108,7 +108,7 @@ =type (&host/lookup-static-field class-loader ?class ?field) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-getstatic (&/P ?class ?field)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) (defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] (|do [class-loader &/loader @@ -116,7 +116,7 @@ =object (&&/analyse-1 analyse ?object) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-getfield ($$ &/P ?class ?field =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) (defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] (|do [class-loader &/loader @@ -124,7 +124,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-putstatic ($$ &/P ?class ?field =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) (defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] (|do [class-loader &/loader @@ -133,7 +133,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-putfield ($$ &/P ?class ?field =object =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) (defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] (|do [class-loader &/loader @@ -143,31 +143,31 @@ ;; [[&/$DataT _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&type/Data$ _class) _arg)) + (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-invokestatic ($$ &/P ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type ?class ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-instanceof (&/P ?class =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) (do-template [<name> <tag>] (defn <name> [analyse exo-type ?class ?method ?classes ?object ?args] (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S <tag> ($$ &/P ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V <tag> (&/T ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual analyse-jvm-invokeinterface &&/$jvm-invokeinterface @@ -179,73 +179,73 @@ =return (if (= "<init>" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) + (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-invokespecial ($$ &/P ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-null? =object) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ "null")] + (|do [:let [output-type (&/V &/$DataT "null")] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-null nil) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&type/Data$ ?class)] + :let [output-type (&/V &/$DataT ?class)] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-new ($$ &/P ?class =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/P (&/S &&/$jvm-new-array (&/P ?class ?length)) (&/S "array" (&/P (&type/Data$ ?class) - (&/S &/$Nil nil))))))) + (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) + (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) =elem (analyse-1+ analyse ?elem) =array-type (&&/expr-type =array)] - (return (&/|list (&/P (&/S &&/$jvm-aastore ($$ &/P =array ?idx =elem)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) (defn analyse-jvm-aaload [analyse ?array ?idx] (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] - (return (&/|list (&/P (&/S &&/$jvm-aaload (&/P =array ?idx)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - [_ (&/$TextS "public")] + (&/$Meta _ (&/$TextS "public")) (return (assoc so-far :visibility "public")) - [_ (&/$TextS "private")] + (&/$Meta _ (&/$TextS "private")) (return (assoc so-far :visibility "private")) - [_ (&/$TextS "protected")] + (&/$Meta _ (&/$TextS "protected")) (return (assoc so-far :visibility "protected")) - [_ (&/$TextS "static")] + (&/$Meta _ (&/$TextS "static")) (return (assoc so-far :static? true)) - [_ (&/$TextS "final")] + (&/$Meta _ (&/$TextS "final")) (return (assoc so-far :final? true)) - [_ (&/$TextS "abstract")] + (&/$Meta _ (&/$TextS "abstract")) (return (assoc so-far :abstract? true)) - [_ (&/$TextS "synchronized")] + (&/$Meta _ (&/$TextS "synchronized")) (return (assoc so-far :concurrency "synchronized")) - [_ (&/$TextS "volatile")] + (&/$Meta _ (&/$TextS "volatile")) (return (assoc so-far :concurrency "volatile")) _ @@ -275,10 +275,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$Nil)))))] + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) + (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) + (&/$Nil)))))) (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers @@ -289,18 +289,18 @@ ?fields) =methods (&/map% (fn [?method] (|case ?method - [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?method-inputs)] - (&/$Cons [_ (&/$TextS ?method-output)] - (&/$Cons [_ (&/$TupleS ?method-modifiers)] - (&/$Cons ?method-body - (&/$Nil)))))))]] + [?idx (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?method-output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-modifiers)) + (&/$Cons ?method-body + (&/$Nil))))))))] (|do [=method-inputs (&/map% (fn [minput] (|case minput - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] - (&/$Cons [_ (&/$TextS ?input-type)] - (&/$Nil))))] - (return (&/P ?input-name ?input-type)) + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) + (&/$Nil))))) + (return (&/T ?input-name ?input-type)) _ (fail "[Analyser Error] Wrong syntax for method input."))) @@ -309,14 +309,14 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype)) + (&&env/with-local iname (&/V &/$DataT (as-otype itype)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/Cons$ (&/P "this" ?super-class) + (&/|cons (&/T ";this" ?super-class) =method-inputs)))))] (return {:name ?method-name :modifiers =method-modifiers @@ -327,18 +327,18 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) - _ (compile-token (&/S &&/$jvm-class ($$ &/P ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] (return (&/|list)))) (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?inputs)] - (&/$Cons [_ (&/$TextS ?output)] - (&/$Cons [_ (&/$TupleS ?modifiers)] - (&/$Nil))))))] + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) + (&/$Nil))))))) (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -349,29 +349,29 @@ _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) - _ (compile-token (&/S &&/$jvm-interface ($$ &/P ?name =supers =methods)))] + _ (compile-token (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] - (return ($$ &/P ?ex-class idx =catch-body)))) + (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (|case ?finally - (&/$None) (return &/None$) + =finally (|case [?finally] + (&/$None) (return (&/V &/$None nil)) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/Some$ =finally))))] - (return (&/|list (&/P (&/S &&/$jvm-try ($$ &/P =body =catches =finally)) exo-type))))) + (return (&/V &/$Some =finally))))] + (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&type/Data$ "java.lang.Throwable") _type)] - (return (&/|list (&/P (&/S &&/$jvm-throw =ex) &type/$Void))))) + _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] + (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) (do-template [<name> <tag>] (defn <name> [analyse exo-type ?monitor] @@ -379,18 +379,18 @@ _ (ensure-object =monitor) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S <tag> =monitor) output-type))))) + (return (&/|list (&/T (&/V <tag> =monitor) output-type))))) analyse-jvm-monitorenter &&/$jvm-monitorenter analyse-jvm-monitorexit &&/$jvm-monitorexit ) (do-template [<name> <tag> <from-class> <to-class>] - (let [output-type (&type/Data$ <to-class>)] + (let [output-type (&/V &/$DataT <to-class>)] (defn <name> [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class>) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT <from-class>) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S <tag> =value) output-type)))))) + (return (&/|list (&/T (&/V <tag> =value) output-type)))))) analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" @@ -413,11 +413,11 @@ ) (do-template [<name> <tag> <from-class> <to-class>] - (let [output-type (&type/Data$ <to-class>)] + (let [output-type (&/V &/$DataT <to-class>)] (defn <name> [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class>) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT <from-class>) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S <tag> =value) output-type)))))) + (return (&/|list (&/T (&/V <tag> =value) output-type)))))) analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" @@ -436,7 +436,7 @@ (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local ?args (&type/App$ &type/List &type/Text) - (&&/analyse-1 analyse (&type/App$ &type/IO &type/Unit) ?body))) - _ (compile-token (&/S &&/$jvm-program =body))] + (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) + _ (compile-token (&/V &&/$jvm-program =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index b30953f67..aeb5a4814 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -9,7 +9,7 @@ (ns lux.analyser.lambda (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case $$]] + (lux [base :as & :refer [|let |do return fail |case]] [host :as &host]) (lux.analyser [base :as &&] [env :as &env]))) @@ -22,19 +22,15 @@ (&env/with-local arg arg-type (|do [=return body =captured &env/captured-vars] - (return ($$ &/P scope-name =captured =return)))))))) + (return (&/T scope-name =captured =return)))))))) (defn close-over [scope name register frame] (|let [[_ register-type] register - register* (&/P (&/S &&/$captured ($$ &/P scope - (->> frame (&/$get-closure) (&/$get-counter)) - register)) + register* (&/T (&/V &&/$captured (&/T scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register)) register-type)] - (do ;; (prn 'close-over 'updating-closure - ;; [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)] - ;; [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text) - ;; (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)]) - ($$ &/P register* (&/$update-closure #(->> % - (&/$update-counter inc) - (&/$update-mappings (fn [mps] (&/|put name register* mps)))) - frame))))) + (&/T register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) + frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 20e435eb3..d241201f4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list |case $$]] + (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -27,64 +27,52 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/P ?item =type)))))) + (return (&/T ?item =type)))))) (defn ^:private with-cursor [cursor form] (|case form - [_ syntax] - (&/P cursor syntax))) + (&/$Meta _ syntax) + (&/V &/$Meta (&/T cursor syntax)))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - ;; (prn 'analyse-tuple/_0 (&type/show-type exo-type) (->> ?elems (&/|map &/show-ast) (&/->seq))) - (|case ?elems - (&/$Nil) - (|do [_ (&type/check exo-type &type/Unit)] - (return (&/|list (&/P (&/S &&/$unit nil) - exo-type)))) - - (&/$Cons single (&/$Nil)) - (fail (str "Tuples can't have only 1 element: " (&/show-ast single))) - - (&/$Cons head tail) - (|do [exo-type* (&type/actual-type exo-type) - ;; :let [_ (prn 'analyse-tuple/_0.25_0 (&/show-ast head) (&/adt->text exo-type*)) - ;; _ (prn 'analyse-tuple/_0.25_1 (&/show-ast head) (&type/show-type exo-type*))] - ] - (|case exo-type* - (&/$ProdT ?left ?right) - (|do [;; :let [_ (prn 'analyse-tuple/_0.5 (&/show-ast head) (&type/show-type ?left))] - =left (&&/analyse-1 analyse ?left head) - ;; :let [_ (prn 'analyse-tuple/_1 =left (&type/show-type ?left))] - =right (|case tail - (&/$Nil) - (fail "Tuples has wrong size.") - - (&/$Cons single (&/$Nil)) - (&&/analyse-1 analyse ?right single) - - _ - (&/ensure-1 (analyse-tuple analyse ?right tail))) - ;; :let [_ (prn 'analyse-tuple/_2 =right (&type/show-type ?right))] - ] - (return (&/|list (&/P (&/S &&/$prod (&/P =left =right)) - exo-type)))) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) - (&/$AllT _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) + (&/$AllT _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-tuple analyse exo-type** ?elems)))) - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))) - )) + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) + +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [output (|case ?values + (&/$Nil) + (analyse-tuple analyse exo-type (&/|list)) + + (&/$Cons ?value (&/$Nil)) + (analyse exo-type ?value) + + _ + (analyse-tuple analyse exo-type ?values) + )] + (|case output + (&/$Cons x (&/$Nil)) + (return x) + + _ + (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn analyse-variant [analyse exo-type idx ?values] - ;; (prn 'analyse-variant/_0 - ;; (&type/show-type exo-type) - ;; idx - ;; (->> ?values (&/|map &/show-ast) (&/->seq))) (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -95,41 +83,82 @@ _ (&type/actual-type exo-type))] (|case exo-type* + (&/$VariantT ?cases) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (analyse-variant-body analyse vtype ?values)] + (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) + exo-type)))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-variant analyse exo-type** idx ?values)))) - - ?variant - (|do [;; :let [_ (prn 'analyse-variant/_1 - ;; (&type/show-type ?variant) - ;; idx - ;; (->> ?values (&/|map &/show-ast) (&/->seq)))] - vtype (&type/variant-case idx ?variant) - ;; :let [_ (prn 'analyse-variant/_2 - ;; idx - ;; (&type/show-type vtype))] - =value (&/ensure-1 (|case ?values - (&/$Nil) - (analyse-tuple analyse vtype (&/|list)) - - (&/$Cons ?value (&/$Nil)) - (analyse vtype ?value) - - _ - (analyse-tuple analyse vtype ?values))) - ;; :let [_ (prn 'analyse-variant/_3 - ;; idx - ;; =value)] - ] - (return (&/|list (&/P (&/S &&/$sum (&/P idx =value)) - exo-type)))) - ))) + + _ + (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) +;; (defn analyse-variant [analyse exo-type ident ?values] +;; (|do [exo-type* (|case exo-type +;; (&/$VarT ?id) +;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] +;; (&type/actual-type exo-type*)) +;; (|do [_ (&type/set-var ?id &type/Type)] +;; (&type/actual-type &type/Type)))) + +;; _ +;; (&type/actual-type exo-type))] +;; (|case exo-type* +;; (&/$VariantT ?cases) +;; (|do [?tag (&&/resolved-ident ident)] +;; (if-let [vtype (&/|get ?tag ?cases)] +;; (|do [=value (analyse-variant-body analyse vtype ?values)] +;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) +;; exo-type)))) +;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + +;; (&/$AllT _) +;; (&type/with-var +;; (fn [$var] +;; (|do [exo-type** (&type/apply-type exo-type* $var)] +;; (analyse-variant analyse exo-type** ident ?values)))) + +;; _ +;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] - (|do [members (&&record/order-record ?elems)] - (analyse-tuple analyse exo-type members))) + (|do [exo-type* (|case exo-type + (&/$VarT ?id) + (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + + (&/$AllT _) + (|do [$var &type/existential + =type (&type/apply-type exo-type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type exo-type $var)] + ;; (&type/actual-type =type)))) + + _ + (&type/actual-type exo-type)) + types (|case exo-type* + (&/$TupleT ?table) + (return ?table) + + _ + (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) + _ (&/assert! (= (&/|length types) (&/|length ?elems)) + (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) + members (&&record/order-record ?elems) + =members (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + types members)] + (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -148,17 +177,14 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] (fn [state] - (|let [stack (&/$get-envs state) - no-binding? #(do ;; (prn 'analyse-local/_ (->> % &/adt->text)) - ;; (prn 'analyse-local/_1 (->> % (&/$get-locals) &/adt->text)) - ;; (prn 'analyse-local/_2 (->> % (&/$get-closure) &/adt->text)) - (and (->> % (&/$get-locals) (&/$get-mappings) (&/|contains? name) not) - (->> % (&/$get-closure) (&/$get-mappings) (&/|contains? name) not))) + (|let [stack (&/get$ &/$envs state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] (|case outer (&/$Nil) @@ -167,8 +193,8 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/$get-locals) (&/$get-mappings) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/$get-locals) (&/$get-mappings) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global [(&/$Global ?module* name*) _] @@ -187,35 +213,32 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type)))) state) - _ - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) + [_] + (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) (fail* "_{_ analyse-symbol _}_"))) (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/$get-name %2) %1) - (&/|map #(&/$get-name %) outer) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) + (&/|map #(&/get$ &/$name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/P register* (&/Cons$ frame* new-inner)))) - (&/P (or (->> top-outer (&/$get-locals) (&/$get-mappings) (&/|get name)) - (->> top-outer (&/$get-closure) (&/$get-mappings) (&/|get name))) + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) - ;; :let [_ (prn 'analyse-local/_0 name) - ;; _ (prn 'analyse-local/_1 name (&type/show-type exo-type) (&type/show-type btype))] - _ (&type/check exo-type btype) - ;; :let [_ (prn 'analyse-local/_2 name 'CHECKED)] - ] + _ (&type/check exo-type btype)] (return (&/|list =local))) - (&/$set-envs (&/|++ inner* outer) state)))) + (&/set$ &/$envs (&/|++ inner* outer) state)))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -230,7 +253,7 @@ (|case ?args (&/$Nil) (|do [_ (&type/check exo-type fun-type)] - (return (&/P fun-type (&/|list)))) + (return (&/T fun-type (&/|list)))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] @@ -248,15 +271,15 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/S &/$BoundT _aarg))] + (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] (&type/clean $var =output-t)))] - (return (&/P type** =args))) + (return (&/T type** =args))) )))) (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/P =output-t (&/Cons$ =arg =args)))) + (return (&/T =output-t (&/|cons =arg =args)))) ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) @@ -277,25 +300,25 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - :let [_ (when (or (= "using" (aget real-name 1)) - ;; (= "type" (aget real-name 1)) - ;; (= &&/$struct r-name) - ) - (->> (&/|map &/show-ast macro-expansion) - (&/|interpose "\n") - (&/fold str "") - (prn (&/ident->text real-name))))] + ;; :let [_ (when (or (= "defsig" (aget real-name 1)) + ;; ;; (= "type" (aget real-name 1)) + ;; ;; (= &&/$struct r-name) + ;; ) + ;; (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (prn (&/ident->text real-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t)))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t))))) ))) @@ -306,7 +329,7 @@ =value (analyse-1+ analyse ?value) =value-type (&&/expr-type =value) =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] - (return (&/|list (&/P (&/S &&/$case (&/P =value =match)) + (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] @@ -325,7 +348,7 @@ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] - (return (&/P (&/S &&/$lambda ($$ &/P =scope =captured =body)) exo-type*))) + (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) _ (fail (str "[Analyser Error] Functions require function types: " @@ -347,22 +370,22 @@ ] (|case dtype (&/$BoundT ?vname) - (return (&/P _expr exo-type)) + (return (&/T _expr exo-type)) (&/$ExT _) - (return (&/P _expr exo-type)) + (return (&/T _expr exo-type)) (&/$VarT ?_id) (|do [?? (&type/bound? ?_id)] - ;; (return (&/P _expr exo-type)) + ;; (return (&/T _expr exo-type)) (if ?? (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) - (return (&/P _expr exo-type))) + (return (&/T _expr exo-type))) ) _ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) - (return (&/P _expr exo-type)))))))) + (return (&/T _expr exo-type)))))))) _ (|do [exo-type* (&type/actual-type exo-type)] @@ -395,7 +418,7 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/S &&/$def (&/P ?name =value))) + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) _ (println 'DEF (str module-name ";" ?name))]] (return (&/|list))))) @@ -405,16 +428,16 @@ (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] module-name &/get-module-name ;; :let [_ (prn 'analyse-declare-macro ?name "1")] - _ (compile-token (&/S &&/$declare-macro (&/P module-name ?name))) + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) ;; :let [_ (prn 'analyse-declare-macro ?name "2")] ] (return (&/|list)))) (defn analyse-declare-tags [tags type-name] (|do [module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] [_ def-data] (&&module/find-def module-name type-name) - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags) (&/adt->text def-data))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] def-type (&&module/ensure-type-def def-data) _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) @@ -446,7 +469,7 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] @@ -454,5 +477,5 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (analyse-1+ analyse ?value)] - (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index bc9647f9f..d23953f5e 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -12,70 +12,69 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [defrtags |let |do return return* fail fail* |case $$]] + (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] [type :as &type] [host :as &host]))) ;; [Utils] -(defrtags - ["module-aliases" - "defs" - "imports" - "tags" - "types"]) +(deftags "" + "module-aliases" + "defs" + "imports" + "tags" + "types") (def ^:private +init+ - ($$ &/P - ;; "lux;module-aliases" - (&/|table) - ;; "lux;defs" - (&/|table) - ;; "lux;imports" - (&/|list) - ;; "lux;tags" - (&/|table) - ;; "lux;types" - (&/|table) - )) + (&/T ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" + (&/|table) + ;; "lux;imports" + (&/|list) + ;; "lux;tags" + (&/|table) + ;; "lux;types" + (&/|table) + )) ;; [Exports] (defn add-import [module] "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/$update-modules - (fn [ms] - (&/|update current-module - (fn [m] ($update-imports (partial &/Cons$ module) m)) - ms)) - state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/update$ $imports (partial &/|cons module) m)) + ms)) + state) nil)))) (defn set-imports [imports] "(-> (List Text) (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/$update-modules - (fn [ms] - (&/|update current-module - (fn [m] ($set-imports imports m)) - ms)) - state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/set$ $imports imports m)) + ms)) + state) nil)))) (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update module - (fn [m] - ($update-defs - #(&/|put name (&/P false def-data) %) - m)) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/T false def-data) %) + m)) + ms)))) nil) _ @@ -84,8 +83,8 @@ (defn def-type [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module))] - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _)] (return* state &type/Type) @@ -105,31 +104,31 @@ (defn type-def [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module))] - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _type)] (return* state _type) _ - (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/P module name))))) - (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/P module name))))) + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) (fail* (str "[Analyser Error] Unknown module: " module))))) (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update a-module - (fn [m] - ($update-defs - #(&/|put a-name (&/P false (&/S &/$AliasD (&/P r-module r-name))) %) - m)) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update a-module + (fn [m] + (&/update$ $defs + #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) + m)) + ms)))) nil) _ @@ -138,30 +137,26 @@ (defn exists? [name] "(-> Text (Lux Bool))" (fn [state] - ;; (prn 'exists?/_0 &/$modules name) - ;; (prn 'exists?/_2 (&/adt->text state)) - ;; (prn 'exists?/_3 (&/adt->text (->> state (&/$get-modules)))) - ;; (prn 'exists?/_4 (&/adt->text (->> state (&/$get-modules) (&/|contains? name)))) (return* state - (->> state (&/$get-modules) (&/|contains? name))))) + (->> state (&/get$ &/$modules) (&/|contains? name))))) (defn alias [module alias reference] (fn [state] (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update module - #($update-module-aliases - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update module + #(&/update$ $module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) nil))) (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] - (if-let [real-name (->> state (&/$get-modules) (&/|get current-module) ($get-module-aliases) (&/|get name))] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] (return* state real-name) (fail* (str "Unknown alias: " name)))))) @@ -169,9 +164,9 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/$get-modules) (&/|get module))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) @@ -182,7 +177,7 @@ state)) _ - (return* state (&/P (&/P module name) $$def))) + (return* state (&/T (&/T module name) $$def))) (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) @@ -203,7 +198,7 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module) ($get-defs))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] (if-let [$def (&/|get name $module)] (|case $def [exported? (&/$ValueD ?type _)] @@ -213,15 +208,15 @@ (.getField &/datum-field) (.get nil))]] (fn [state*] - (return* (&/$update-modules - (fn [$modules] - (&/|update module - (fn [m] - ($update-defs - #(&/|put name (&/P exported? (&/S &/$MacroD macro)) %) - m)) - $modules)) - state*) + (return* (&/update$ &/$modules + (fn [$modules] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) + m)) + $modules)) + state*) nil))) state) @@ -235,21 +230,21 @@ (defn export [module name] (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) - (if-let [$def (->> state (&/$get-modules) (&/|get module) ($get-defs) (&/|get name))] + (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] (|case $def [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) [false ?data] (return* (->> state - (&/$update-modules (fn [ms] - (&/|update module (fn [m] - ($update-defs - #(&/|put name (&/P true ?data) %) - m)) - ms)))) + (&/update$ &/$modules (fn [ms] + (&/|update module (fn [m] + (&/update$ $defs + #(&/|put name (&/T true ?data) %) + m)) + ms)))) nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) @@ -265,61 +260,61 @@ (do ;; (prn 'defs k ?exported?) (|case ?def (&/$AliasD ?r-module ?r-name) - ($$ &/P ?exported? k (str "A" ?r-module ";" ?r-name)) + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) (&/$MacroD _) - ($$ &/P ?exported? k "M") + (&/T ?exported? k "M") (&/$TypeD _) - ($$ &/P ?exported? k "T") + (&/T ?exported? k "T") _ - ($$ &/P ?exported? k "V"))))) - (->> state (&/$get-modules) (&/|get module) ($get-defs))))))) + (&/T ?exported? k "V"))))) + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) (def imports (|do [module &/get-module-name] (fn [state] - (return* state (->> state (&/$get-modules) (&/|get module) ($get-imports)))))) + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports)))))) (defn create-module [name] "(-> Text (Lux (,)))" (fn [state] - (return* (&/$update-modules #(&/|put name +init+ %) state) nil))) + (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil))) (defn enter-module [name] "(-> Text (Lux (,)))" (fn [state] (return* (->> state - (&/$update-modules #(&/|put name +init+ %)) - (&/$set-envs (&/|list (&/env name)))) + (&/update$ &/$modules #(&/|put name +init+ %)) + (&/set$ &/$envs (&/|list (&/env name)))) nil))) -(do-template [<name> <getter> <type>] +(do-template [<name> <tag> <type>] (defn <name> [module] <type> (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (return* state (<getter> =module)) + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ <tag> =module)) (fail* (str "[Lux Error] Unknown module: " module))) )) - tags-by-module $get-tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" - types-by-module $get-types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" ) (defn ensure-undeclared-tags [module tags] (|do [tags-table (tags-by-module module) _ (&/map% (fn [tag] (if (&/|get tag tags-table) - (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/P module tag)))) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) (return nil))) tags)] (return nil))) (defn ensure-undeclared-type [module name] (|do [types-table (types-by-module module) - _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/P module name))))] + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] (return nil))) (defn declare-tags [module tag-names type] @@ -332,34 +327,37 @@ (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) _ (ensure-undeclared-type _module _name)] (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/P module tag-name)) tag-names)] - (return* (&/$update-modules - (fn [=modules] - (&/|update module - #(->> % - ($set-tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name ($$ &/P idx tags type) table))) - ($get-tags %) - (&/enumerate tag-names))) - ($update-types (partial &/|put _name (&/P tags type)))) - =modules)) - state) + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags type) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T tags type)))) + =modules)) + state) nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) -(do-template [<name> <member> <type>] - (defn <name> [module tag-name] - <type> - (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] - (|let [[idx tags type] idx+tags] - (return* state <member>)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) - - tag-index idx "(-> Text Text (Lux Int))" - tag-group tags "(-> Text Text (Lux (List Ident)))" - ) +(defn tag-index [module tag-name] + "(-> Text Text (Lux Int))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 0)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + +(defn tag-group [module tag-name] + "(-> Text Text (Lux (List Ident)))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 1)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 96c988544..2b4b7e095 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -13,6 +13,122 @@ (lux.analyser [base :as &&] [module :as &&module]))) +;; [Tags] +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) + ;; [Exports] (defn order-record [pairs] "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" @@ -20,7 +136,7 @@ (&/$Nil) (return (&/|list)) - (&/$Cons [[_ (&/$TagS tag1)] _] _) + (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) (|do [[module name] (&&/resolved-ident tag1)] (&&module/tag-group module name)) @@ -28,9 +144,9 @@ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv - [[_ (&/$TagS k)] v] + [(&/$Meta _ (&/$TagS k)) v] (|do [=k (&&/resolved-ident k)] - (return (&/P (&/ident->text =k) v))) + (return (&/T (&/ident->text =k) v))) _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) |