diff options
| author | Eduardo Julian | 2015-08-23 02:54:00 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2015-08-23 02:54:00 -0400 |
| commit | 9606c19f9947c8f2ff5647b4613ac2029ac3881f (patch) | |
| tree | cf4f2fdd8e9d985ae6f4c8fbd2c1922b46e386bc /src | |
| parent | b059fa2a5efb4cab8b62d895e8c9adf1434bde2d (diff) | |
- Restructuring how sums & products work [part 1]
Diffstat (limited to 'src')
| -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 | 355 | ||||
| -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 | 255 | ||||
| -rw-r--r-- | src/lux/analyser/module.clj | 247 | ||||
| -rw-r--r-- | src/lux/analyser/record.clj | 122 | ||||
| -rw-r--r-- | src/lux/base.clj | 527 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 18 | ||||
| -rw-r--r-- | src/lux/compiler/base.clj | 44 | ||||
| -rw-r--r-- | src/lux/compiler/cache.clj | 8 | ||||
| -rw-r--r-- | src/lux/compiler/case.clj | 89 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 26 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 75 | ||||
| -rw-r--r-- | src/lux/compiler/module.clj | 4 | ||||
| -rw-r--r-- | src/lux/compiler/type.clj | 89 | ||||
| -rw-r--r-- | src/lux/host.clj | 6 | ||||
| -rw-r--r-- | src/lux/lexer.clj | 66 | ||||
| -rw-r--r-- | src/lux/parser.clj | 62 | ||||
| -rw-r--r-- | src/lux/reader.clj | 54 | ||||
| -rw-r--r-- | src/lux/type.clj | 627 |
23 files changed, 1725 insertions, 1798 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 8c88328f5..41a59fc00 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 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))) + [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))) _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private parse-tag [ast] (|case ast - (&/$Meta _ (&/$TagS "" name)) + [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) - (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) - (&/$Cons (&/$Meta _ (&/$IntS ?length)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] + (&/$Cons [_ (&/$SymbolS _ ?class)] + (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons ?array - (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons ?array - (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - (&/$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)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?fields)] + (&/$Cons [_ (&/$TupleS ?methods)] (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) - (&/$Cons (&/$Meta _ (&/$TextS ?name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TupleS ?supers)] ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] + (&/$Cons [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")] (&/$Cons ?object (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")] + (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?object (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?object (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?value (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?object (&/$Cons ?value (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] (&/$Cons ?body ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] + (|do [catches+finally (&/fold% parse-handler (&/P (&/|list) &/None$) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] (&/$Cons ?ex (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")] (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) + (&/$FormS (&/$Cons [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_lux_case")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")] (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")] + (&/$Cons [_ (&/$SymbolS "" ?self)] + (&/$Cons [_ (&/$SymbolS "" ?arg)] (&/$Cons ?body (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] + (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] + (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) - (&/$Cons (&/$Meta _ (&/$TupleS tags)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] + (&/$Cons [_ (&/$TupleS tags)] + (&/$Cons [_ (&/$SymbolS "" type-name)] (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] (&&lux/analyse-declare-tags tags* type-name)) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) - (&/$Cons (&/$Meta _ (&/$TextS ?path)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] + (&/$Cons [_ (&/$TextS ?path)] (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")] (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")] (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] + (&/$Cons [_ (&/$SymbolS "" ?ident)] (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) - (&/$Cons (&/$Meta _ (&/$TextS ?alias)) - (&/$Cons (&/$Meta _ (&/$TextS ?module)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] + (&/$Cons [_ (&/$TextS ?alias)] + (&/$Cons [_ (&/$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 (&/T (&/V &&/$bool ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$bool ?value) exo-type)))) (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$int ?value) exo-type)))) (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$real ?value) exo-type)))) (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$char ?value) exo-type)))) (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$text ?value) exo-type)))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) @@ -528,20 +528,21 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - (&/$Meta meta ?token) + [meta ?token] (fn [state] - (|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))))) + (|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))))) (&/$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)) )) )) @@ -553,42 +554,44 @@ [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] - (return (&/T ?output-term ?output-type*))) - (return (&/T ?output-term ?output-type))) + (return (&/P ?output-term ?output-type*))) + (return (&/P ?output-term ?output-type))) [_ _] - (return (&/T ?output-term ?output-type))) + (return (&/P ?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)) - (&/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))))) + (|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)))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index fe1e0d55b..622f0b853 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" - "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" - - ) +(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" + ]) ;; [Exports] (defn expr-type [syntax+] @@ -147,4 +147,4 @@ (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] - (return (&/T module* ?name))))) + (return (&/P module* ?name))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 483002adc..aab25d741 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,31 +18,31 @@ [record :as &&record]))) ;; [Tags] -(deftags "" - "DefaultTotal" - "BoolTotal" - "IntTotal" - "RealTotal" - "CharTotal" - "TextTotal" - "TupleTotal" - "VariantTotal" +(deftags + ["DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "ProdTotal" + "SumTotal"] ) -(deftags "" - "StoreTestAC" - "BoolTestAC" - "IntTestAC" - "RealTestAC" - "CharTestAC" - "TextTestAC" - "TupleTestAC" - "VariantTestAC" +(deftags + ["StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "ProdTestAC" + "SumTestAC"] ) ;; [Utils] (def ^:private unit - (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) + (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS (&/|list)))) (defn ^:private resolve-type [type] (|case type @@ -64,74 +64,66 @@ _ (&type/actual-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))) - )) +(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 [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) + 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] + (|let [[_ pattern*] pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/T (&/V $StoreTestAC idx) =kont))) + (return (&/P (&/S $StoreTestAC idx) =kont))) (&/$SymbolS ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) @@ -139,194 +131,152 @@ (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/T (&/V $BoolTestAC ?value) =kont))) + (return (&/P (&/S $BoolTestAC ?value) =kont))) (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/T (&/V $IntTestAC ?value) =kont))) + (return (&/P (&/S $IntTestAC ?value) =kont))) (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/T (&/V $RealTestAC ?value) =kont))) + (return (&/P (&/S $RealTestAC ?value) =kont))) (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/T (&/V $CharTestAC ?value) =kont))) + (return (&/P (&/S $CharTestAC ?value) =kont))) (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/T (&/V $TextTestAC ?value) =kont))) + (return (&/P (&/S $TextTestAC ?value) =kont))) - (&/$TupleS ?members) + (&/$TupleS (&/$Cons ?_left ?tail)) (|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* - (&/$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)))) + (&/$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 (&/S &/$TupleS ?tail) kont))] + (return (&/P =right =kont))))] + (return (&/P (&/S $ProdTestAC =left =right) =kont))) _ - (fail "[Pattern-matching Error] Record requires record-type."))) + (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 (&/S &/$TupleS ?members) kont)) (&/$TagS ?ident) - (|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))) + (|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 (&/$Meta _ (&/$TagS ?ident)) + (&/$FormS (&/$Cons [_ (&/$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))] + (|do [[idx group-count case-type] (resolve-tag ?ident value-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 (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) + (analyse-pattern case-type (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS ?values)) kont)) ;; :let [_ (println "#15")] ] - (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =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 (&/V $DefaultTotal true)) + (return (&/S $DefaultTotal true)) [[?tag [total? ?values]] ($StoreTestAC ?idx)] - (return (&/V ?tag (&/T true ?values))) + (return (&/S ?tag (&/P true ?values))) [($DefaultTotal total?) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) + (return (&/S $BoolTotal (&/P total? (&/|list ?value)))) [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $BoolTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T total? (&/|list ?value)))) + (return (&/S $IntTotal (&/P total? (&/|list ?value)))) [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $IntTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T total? (&/|list ?value)))) + (return (&/S $RealTotal (&/P total? (&/|list ?value)))) [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $RealTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T total? (&/|list ?value)))) + (return (&/S $CharTotal (&/P total? (&/|list ?value)))) [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $CharTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T total? (&/|list ?value)))) + (return (&/S $TextTotal (&/P total? (&/|list ?value)))) [($TextTotal total? ?values) ($TextTestAC ?value)] - (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?))) + (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values)))) + + [($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?))) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/V $VariantTotal (&/T total? structs)))) + (return (&/S $SumTotal (&/P total? structs)))) - [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] + [($SumTotal total? ?branches) ($SumTestAC ?tag ?count ?test)] (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) (&/$Some sub) sub (&/$None) - (&/V $DefaultTotal total?)) - (&/T ?test ?body)) + (&/S $DefaultTotal total?)) + (&/P ?test ?body)) structs (|case (&/|list-put ?tag sub-struct ?branches) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/V $VariantTotal (&/T total? structs)))) + (return (&/S $SumTotal (&/P total? structs)))) )))) (defn ^:private check-totality [value-type struct] @@ -351,33 +301,36 @@ ($TextTotal ?total _) (return ?total) - ($TupleTotal ?total ?structs) + ($ProdTotal ?total ?_left ?_right) (if ?total (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$TupleT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) + (&/$ProdT ?left ?right) + (|do [=left (check-totality ?left ?_left) + =right (check-totality ?right ?_right)] + (return (and =left =right))) _ (fail "[Pattern-maching Error] Tuple is not total.")))) - ($VariantTotal ?total ?structs) + ($SumTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (|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))) + (|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 ($SumTotal ?total ?tail)))] + (return (and =left =right))) _ (fail "[Pattern-maching Error] Variant is not total.")))) @@ -394,7 +347,7 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) + struct (&/fold% merge-total (&/S $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 4e9dcd79f..5686700e3 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 (&/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))] + (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))] (|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 64f297994..69aa95f12 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 - (&/$Meta _ (&/$TextS ?text)) + [_ (&/$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 (&/T ?item =type)))))) + (return (&/P ?item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" @@ -47,20 +47,20 @@ "(-> Type Type)" (|case type (&/$DataT class) - (&/V &/$DataT (&type/as-obj class)) + (&type/Data$ (&type/as-obj class)) _ type)) ;; [Resources] (do-template [<name> <output-tag> <input-class> <output-class>] - (let [input-type (&/V &/$DataT <input-class>) - output-type (&/V &/$DataT <output-class>)] + (let [input-type (&type/Data$ <input-class>) + output-type (&type/Data$ <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 (&/T (&/V <output-tag> (&/T =x =y)) output-type)))))) + (return (&/|list (&/P (&/S <output-tag> (&/P =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 (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-getstatic (&/P ?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 (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-getfield ($$ &/P ?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 (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-putstatic ($$ &/P ?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 (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-putfield ($$ &/P ?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 (&/V &/$DataT _class) _arg)) + (&&/analyse-1 analyse (&type/Data$ _class) _arg)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-invokestatic ($$ &/P ?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 (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-instanceof (&/P ?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 (&/V &/$DataT ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) + =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V <tag> (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/P (&/S <tag> ($$ &/P ?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 (&/V &/$DataT ?class) ?object) + =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) + (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-invokespecial ($$ &/P ?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 (&/T (&/V &&/$jvm-null? =object) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&/V &/$DataT "null")] + (|do [:let [output-type (&type/Data$ "null")] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) + (return (&/|list (&/P (&/S &&/$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 (&/V &/$DataT ?class)] + :let [output-type (&type/Data$ ?class)] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-new ($$ &/P ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) - (&/V &/$Nil nil))))))) + (return (&/|list (&/P (&/S &&/$jvm-new-array (&/P ?class ?length)) (&/S "array" (&/P (&type/Data$ ?class) + (&/S &/$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 (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) + (return (&/|list (&/P (&/S &&/$jvm-aastore ($$ &/P =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 (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) + (return (&/|list (&/P (&/S &&/$jvm-aaload (&/P =array ?idx)) =array-type))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - (&/$Meta _ (&/$TextS "public")) + [_ (&/$TextS "public")] (return (assoc so-far :visibility "public")) - (&/$Meta _ (&/$TextS "private")) + [_ (&/$TextS "private")] (return (assoc so-far :visibility "private")) - (&/$Meta _ (&/$TextS "protected")) + [_ (&/$TextS "protected")] (return (assoc so-far :visibility "protected")) - (&/$Meta _ (&/$TextS "static")) + [_ (&/$TextS "static")] (return (assoc so-far :static? true)) - (&/$Meta _ (&/$TextS "final")) + [_ (&/$TextS "final")] (return (assoc so-far :final? true)) - (&/$Meta _ (&/$TextS "abstract")) + [_ (&/$TextS "abstract")] (return (assoc so-far :abstract? true)) - (&/$Meta _ (&/$TextS "synchronized")) + [_ (&/$TextS "synchronized")] (return (assoc so-far :concurrency "synchronized")) - (&/$Meta _ (&/$TextS "volatile")) + [_ (&/$TextS "volatile")] (return (assoc so-far :concurrency "volatile")) _ @@ -275,10 +275,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) - (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) - (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) - (&/$Nil)))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Cons [_ (&/$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 (&/$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))))))))] + [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] + (&/$Cons [_ (&/$TupleS ?method-inputs)] + (&/$Cons [_ (&/$TextS ?method-output)] + (&/$Cons [_ (&/$TupleS ?method-modifiers)] + (&/$Cons ?method-body + (&/$Nil)))))))]] (|do [=method-inputs (&/map% (fn [minput] (|case minput - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) - (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) - (&/$Nil))))) - (return (&/T ?input-name ?input-type)) + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] + (&/$Cons [_ (&/$TextS ?input-type)] + (&/$Nil))))] + (return (&/P ?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 (&/V &/$DataT (as-otype itype)) + (&&env/with-local iname (&type/Data$ (as-otype itype)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/|cons (&/T ";this" ?super-class) + (&/Cons$ (&/P "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 (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/S &&/$jvm-class ($$ &/P ?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 - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) - (&/$Cons (&/$Meta _ (&/$TextS ?output)) - (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) - (&/$Nil))))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] + (&/$Cons [_ (&/$TupleS ?inputs)] + (&/$Cons [_ (&/$TextS ?output)] + (&/$Cons [_ (&/$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 (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] + _ (compile-token (&/S &&/$jvm-interface ($$ &/P ?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 (&/V &/$DataT ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] - (return (&/T ?ex-class idx =catch-body)))) + (return ($$ &/P ?ex-class idx =catch-body)))) ?catches) - =finally (|case [?finally] - (&/$None) (return (&/V &/$None nil)) + =finally (|case ?finally + (&/$None) (return &/None$) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V &/$Some =finally))))] - (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) + (return (&/Some$ =finally))))] + (return (&/|list (&/P (&/S &&/$jvm-try ($$ &/P =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 (&/V &/$DataT "java.lang.Throwable") _type)] - (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) + _ (&type/check (&type/Data$ "java.lang.Throwable") _type)] + (return (&/|list (&/P (&/S &&/$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 (&/T (&/V <tag> =monitor) output-type))))) + (return (&/|list (&/P (&/S <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 (&/V &/$DataT <to-class>)] + (let [output-type (&type/Data$ <to-class>)] (defn <name> [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V &/$DataT <from-class>) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class>) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V <tag> =value) output-type)))))) + (return (&/|list (&/P (&/S <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 (&/V &/$DataT <to-class>)] + (let [output-type (&type/Data$ <to-class>)] (defn <name> [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V &/$DataT <from-class>) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class>) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V <tag> =value) output-type)))))) + (return (&/|list (&/P (&/S <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 (&/V &/$AppT (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) - _ (compile-token (&/V &&/$jvm-program =body))] + (&&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))] (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index aeb5a4814..696c816e9 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,15 +22,19 @@ (&env/with-local arg arg-type (|do [=return body =captured &env/captured-vars] - (return (&/T scope-name =captured =return)))))))) + (return ($$ &/P scope-name =captured =return)))))))) (defn close-over [scope name register frame] (|let [[_ register-type] register - register* (&/T (&/V &&/$captured (&/T scope - (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) - register)) + register* (&/P (&/S &&/$captured ($$ &/P scope + (->> frame (&/$get-closure) (&/$get-counter)) + register)) register-type)] - (&/T register* (&/update$ &/$closure #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) - frame)))) + (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))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index d241201f4..f7ed07ee4 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,52 +27,64 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) + (return (&/P ?item =type)))))) (defn ^:private with-cursor [cursor form] (|case form - (&/$Meta _ syntax) - (&/V &/$Meta (&/T cursor syntax)))) + [_ syntax] + (&/P cursor syntax))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - (|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)))) - - _ - (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) + ;; (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)))) - _ - (analyse-tuple analyse exo-type ?values) - )] - (|case output - (&/$Cons x (&/$Nil)) - (return x) + (&/$AllT _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-tuple analyse exo-type** ?elems)))) - _ - (fail "[Analyser Error] Can't expand to other than 1 element.")))) + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))) + )) (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)] @@ -83,82 +95,41 @@ _ (&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)))) - - _ - (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 [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)))) + ?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)))) + ))) - _ - (&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 analyse-record [analyse exo-type ?elems] + (|do [members (&&record/order-record ?elems)] + (analyse-tuple analyse exo-type members))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -177,14 +148,17 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] (fn [state] - (|let [stack (&/get$ &/$envs state) - no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) - (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) + (|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))) [inner outer] (&/|split-with no-binding? stack)] (|case outer (&/$Nil) @@ -193,8 +167,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*) _] @@ -213,32 +187,31 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) endo-type)))) state) - [_] - (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* "[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)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) - (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) + (&/P register* (&/Cons$ frame* new-inner)))) + (&/P (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) _ (&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] @@ -253,7 +226,7 @@ (|case ?args (&/$Nil) (|do [_ (&type/check exo-type fun-type)] - (return (&/T fun-type (&/|list)))) + (return (&/P fun-type (&/|list)))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] @@ -271,15 +244,15 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] + (|do [_ (&type/set-var ?id (&/S &/$BoundT _aarg))] (&type/clean $var =output-t)))] - (return (&/T type** =args))) + (return (&/P 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 (&/T =output-t (&/|cons =arg =args)))) + (return (&/P =output-t (&/Cons$ =arg =args)))) ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) @@ -313,12 +286,12 @@ _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) + (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) =output-t)))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) + (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) =output-t))))) ))) @@ -329,7 +302,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 (&/T (&/V &&/$case (&/T =value =match)) + (return (&/|list (&/P (&/S &&/$case (&/P =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] @@ -348,7 +321,7 @@ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) + (return (&/P (&/S &&/$lambda ($$ &/P =scope =captured =body)) exo-type*))) _ (fail (str "[Analyser Error] Functions require function types: " @@ -370,22 +343,22 @@ ] (|case dtype (&/$BoundT ?vname) - (return (&/T _expr exo-type)) + (return (&/P _expr exo-type)) (&/$ExT _) - (return (&/T _expr exo-type)) + (return (&/P _expr exo-type)) (&/$VarT ?_id) (|do [?? (&type/bound? ?_id)] - ;; (return (&/T _expr exo-type)) + ;; (return (&/P _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 (&/T _expr exo-type))) + (return (&/P _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 (&/T _expr exo-type)))))))) + (return (&/P _expr exo-type)))))))) _ (|do [exo-type* (&type/actual-type exo-type)] @@ -418,7 +391,7 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + (|do [_ (compile-token (&/S &&/$def (&/P ?name =value))) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) _ (println 'DEF (str module-name ";" ?name))]] (return (&/|list))))) @@ -428,16 +401,16 @@ (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] module-name &/get-module-name ;; :let [_ (prn 'analyse-declare-macro ?name "1")] - _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) + _ (compile-token (&/S &&/$declare-macro (&/P 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 (&/T module-name type-name)) (&/->seq tags))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags))] [_ def-data] (&&module/find-def module-name type-name) - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P 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)))) @@ -469,7 +442,7 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) + (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] @@ -477,5 +450,5 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (analyse-1+ analyse ?value)] - (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) + (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index d23953f5e..909e7e2c4 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -12,69 +12,70 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] + (lux [base :as & :refer [defrtags |let |do return return* fail fail* |case $$]] [type :as &type] [host :as &host]))) ;; [Utils] -(deftags "" - "module-aliases" - "defs" - "imports" - "tags" - "types") +(defrtags + ["module-aliases" + "defs" + "imports" + "tags" + "types"]) (def ^:private +init+ - (&/T ;; "lux;module-aliases" - (&/|table) - ;; "lux;defs" - (&/|table) - ;; "lux;imports" - (&/|list) - ;; "lux;tags" - (&/|table) - ;; "lux;types" - (&/|table) - )) + ($$ &/P + ;; "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 (&/T false def-data) %) - m)) - ms)))) + (&/$update-modules + (fn [ms] + (&/|update module + (fn [m] + ($update-defs + #(&/|put name (&/P false def-data) %) + m)) + ms)))) nil) _ @@ -83,8 +84,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) @@ -104,31 +105,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 (&/T module name))))) - (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) + (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] 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 (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) - m)) - ms)))) + (&/$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)))) nil) _ @@ -137,26 +138,30 @@ (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)))))) @@ -164,9 +169,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)) @@ -177,7 +182,7 @@ state)) _ - (return* state (&/T (&/T module name) $$def))) + (return* state (&/P (&/P 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)))))) @@ -198,7 +203,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 _)] @@ -208,15 +213,15 @@ (.getField &/datum-field) (.get nil))]] (fn [state*] - (return* (&/update$ &/$modules - (fn [$modules] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) - m)) - $modules)) - state*) + (return* (&/$update-modules + (fn [$modules] + (&/|update module + (fn [m] + ($update-defs + #(&/|put name (&/P exported? (&/S &/$MacroD macro)) %) + m)) + $modules)) + state*) nil))) state) @@ -230,21 +235,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 (&/T true ?data) %) - m)) - ms)))) + (&/$update-modules (fn [ms] + (&/|update module (fn [m] + ($update-defs + #(&/|put name (&/P true ?data) %) + m)) + ms)))) nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) @@ -260,61 +265,61 @@ (do ;; (prn 'defs k ?exported?) (|case ?def (&/$AliasD ?r-module ?r-name) - (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + ($$ &/P ?exported? k (str "A" ?r-module ";" ?r-name)) (&/$MacroD _) - (&/T ?exported? k "M") + ($$ &/P ?exported? k "M") (&/$TypeD _) - (&/T ?exported? k "T") + ($$ &/P ?exported? k "T") _ - (&/T ?exported? k "V"))))) - (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) + ($$ &/P ?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> <tag> <type>] +(do-template [<name> <getter> <type>] (defn <name> [module] <type> (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (return* state (&/get$ <tag> =module)) + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (return* state (<getter> =module)) (fail* (str "[Lux Error] Unknown module: " module))) )) - tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" - types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + 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)))))" ) (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 (&/T module tag)))) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/P 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 (&/T module name))))] + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/P module name))))] (return nil))) (defn declare-tags [module tag-names type] @@ -327,37 +332,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] (&/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) + (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) nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) (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))] + (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 tag: " (&/ident->text (&/P 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))] + (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 tag: " (&/ident->text (&/P 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 2b4b7e095..96c988544 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -13,122 +13,6 @@ (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)))" @@ -136,7 +20,7 @@ (&/$Nil) (return (&/|list)) - (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) + (&/$Cons [[_ (&/$TagS tag1)] _] _) (|do [[module name] (&&/resolved-ident tag1)] (&&module/tag-group module name)) @@ -144,9 +28,9 @@ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv - [(&/$Meta _ (&/$TagS k)) v] + [[_ (&/$TagS k)] v] (|do [=k (&&/resolved-ident k)] - (return (&/T (&/ident->text =k) v))) + (return (&/P (&/ident->text =k) v))) _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 6247524af..2f0925586 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -11,99 +11,157 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) -;; [Tags] -(defmacro deftags [prefix & names] +;; [ADTs] +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) + +(defmacro deftags [names] + (assert (vector? names)) `(do ~@(for [[name idx] (map vector names (range (count names)))] `(def ~(symbol (str "$" name)) ~idx)))) +(defn ^:private unfold-accesses + ([elems] + (unfold-accesses 1 (count elems) elems)) + ([begin end elems] + (if (= begin end) + (list elems) + (cons (take begin elems) + (unfold-accesses (inc begin) end elems))))) + +(defmacro defrtags [tags] + (let [num-tags (count tags) + normals (butlast tags) + special (last tags) + tags+locs (cons [special (repeat (dec num-tags) 1)] + (map #(vector %1 (concat (repeat %2 1) [0])) + normals + (range num-tags)))] + `(do ~@(for [[tag loc] tags+locs + :let [getter (symbol (str "$get-" tag)) + setter (symbol (str "$set-" tag)) + updater (symbol (str "$update-" tag)) + record (gensym "record") + value (gensym "value")]] + `(do (defn ~getter [~record] + ;; (if (= '~'$get-source '~getter) + ;; (prn '~getter '~loc ~record (aget ~record ~@loc)) + ;; (prn '~getter '~loc ~record (adt->text (aget ~record ~@loc)))) + (aget ~record ~@loc)) + (defn ~setter [~value ~record] + ;; (if (= '~'$set-source '~setter) + ;; (prn '~setter '_1 '~loc ~record) + ;; (prn '~setter '_2 '~loc ~record (adt->text ~value))) + ;; (doto record# + ;; (aset ~@loc value#)) + ;; (doto record# + ;; (aset 1 (doto (aget record# 1) + ;; (aset 1 ...)))) + ~(reduce (fn [inner indices] + `(doto (aclone ~(if (= 1 (count indices)) + record + `(aget ~record ~@(butlast indices)))) + (aset ~(last indices) ~inner))) + value + (reverse (unfold-accesses loc))) + ) + (defn ~updater [f# ~record] + ;; (prn '~updater '~loc ~record) + ;; (doto record# + ;; (aset ~@loc (f# (aget record# ~@loc)))) + (~setter (f# (~getter ~record)) ~record))))) + )) + ;; List -(deftags "" - "Nil" - "Cons") +(deftags + ["Nil" + "Cons"]) ;; Maybe -(deftags "" - "None" - "Some") - -;; Meta -(deftags "" - "Meta") +(deftags + ["None" + "Some"]) ;; Either -(deftags "" - "Left" - "Right") +(deftags + ["Left" + "Right"]) ;; AST -(deftags "" - "BoolS" - "IntS" - "RealS" - "CharS" - "TextS" - "SymbolS" - "TagS" - "FormS" - "TupleS" - "RecordS") +(deftags + ["BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS"]) ;; Type -(deftags "" - "DataT" - "VariantT" - "TupleT" - "LambdaT" - "BoundT" - "VarT" - "ExT" - "AllT" - "AppT" - "NamedT") +(deftags + ["VoidT" + "UnitT" + "SumT" + "ProdT" + "DataT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "AllT" + "AppT" + "NamedT"]) ;; Vars -(deftags "lux;" - "Local" - "Global") +(deftags + ["Local" + "Global"]) ;; Definitions -(deftags "lux;" - "ValueD" - "TypeD" - "MacroD" - "AliasD") +(deftags + ["ValueD" + "TypeD" + "MacroD" + "AliasD"]) ;; Binding -(deftags "" - "counter" - "mappings") +(defrtags + ["counter" + "mappings"]) ;; Env -(deftags "" - "name" - "inner-closures" - "locals" - "closure") +(defrtags + ["name" + "inner-closures" + "locals" + "closure"]) ;; Host -(deftags "" - "writer" - "loader" - "classes") +(defrtags + ["writer" + "loader" + "classes"]) ;; Compiler -(deftags "" - "source" - "cursor" - "modules" - "envs" - "type-vars" - "expected" - "seed" - "eval?" - "host") +(defrtags + ["source" + "cursor" + "modules" + "envs" + "type-vars" + "expected" + "seed" + "eval?" + "host"]) ;; [Exports] +;; Class fields (def datum-field "_datum") (def meta-field "_meta") (def name-field "_name") @@ -117,55 +175,59 @@ (def +name-separator+ ";") -(defn T [& elems] - (to-array elems)) - -(defn V [^Long tag value] - (to-array [tag value])) +(def prelude-name "lux") -;; Constructors -(def None$ (V $None nil)) -(defn Some$ [x] (V $Some x)) +(defmacro $$ [op & args] + (assert (> (count args) 1) + (prn-str '$$ op args)) + (let [[last & others] (reverse args)] + (reduce (fn [right left] `(~op ~left ~right)) + last + others))) -(def Nil$ (V $Nil nil)) -(defn Cons$ [h t] (V $Cons (T h t))) +(defn S [^Long tag value] + (to-array [tag value])) -(defn get$ [slot ^objects record] - (aget record slot)) +(defn P [left right] + (to-array [left right])) -(defn set$ [slot value ^objects record] - (let [record* (aclone record) - size (alength record)] - (aset record* slot value) - record*)) +;; Constructors +(def None$ (S $None nil)) +(defn Some$ [x] (S $Some x)) -(defmacro update$ [slot f record] - `(let [record# ~record] - (set$ ~slot (~f (get$ ~slot record#)) - record#))) +(def Nil$ (S $Nil nil)) +(defn Cons$ [h t] (S $Cons (P h t))) (defn fail* [message] - (V $Left message)) + (S $Left message)) (defn return* [state value] - (V $Right (T state value))) + (S $Right (P state value))) + +(defn ^:private transform-tuple-pattern [pattern] + (case (count pattern) + 0 '_ + 1 (assert false "Can't have singleton tuples.") + 2 pattern + ;; else + (let [[last & others] (reverse pattern)] + (reduce (fn [r l] [l r]) last others)))) (defn transform-pattern [pattern] - (cond (vector? pattern) (mapv transform-pattern pattern) + (cond (vector? pattern) (transform-tuple-pattern (mapv transform-pattern pattern)) (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] (vec (cons (eval (first pattern)) (list (case (count parts) - 0 '_ 1 (first parts) ;; else - `[~@parts]))))) + (transform-tuple-pattern parts)))))) :else pattern )) (defmacro |case [value & branches] (assert (= 0 (mod (count branches) 2))) (let [value* (if (vector? value) - [`(T ~@value)] + [`($$ P ~@value)] [value])] `(matchv ::M/objects ~value* ~@(mapcat (fn [[pattern body]] @@ -183,8 +245,8 @@ (defmacro |list [& elems] (reduce (fn [tail head] - `(V $Cons (T ~head ~tail))) - `(V $Nil nil) + `(Cons$ ~head ~tail)) + `Nil$ (reverse elems))) (defmacro |table [& elems] @@ -204,17 +266,18 @@ (|get slot table*)))) (defn |put [slot value table] + ;; (prn '|put slot (adt->text value) (adt->text table)) (|case table ($Nil) - (V $Cons (T (T slot value) (V $Nil nil))) + (Cons$ (P slot value) Nil$) ($Cons [k v] table*) (if (.equals ^Object k slot) - (V $Cons (T (T slot value) table*)) - (V $Cons (T (T k v) (|put slot value table*)))) + (Cons$ (P slot value) table*) + (Cons$ (P k v) (|put slot value table*))) ;; _ - ;; (assert false (prn-str '|put (aget table 0))) + ;; (assert false (prn-str '|put slot (adt->text value) (adt->text table))) )) (defn |remove [slot table] @@ -225,7 +288,7 @@ ($Cons [k v] table*) (if (.equals ^Object k slot) table* - (V $Cons (T (T k v) (|remove slot table*)))))) + (Cons$ (P k v) (|remove slot table*))))) (defn |update [k f table] (|case table @@ -234,8 +297,8 @@ ($Cons [k* v] table*) (if (.equals ^Object k k*) - (V $Cons (T (T k* (f v)) table*)) - (V $Cons (T (T k* v) (|update k f table*)))))) + (Cons$ (P k* (f v)) table*) + (Cons$ (P k* v) (|update k f table*))))) (defn |head [xs] (|case xs @@ -256,11 +319,11 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - (V $Left message))) + (S $Left message))) (defn return [value] (fn [state] - (V $Right (T state value)))) + (S $Right (P state value)))) (defn bind [m-value step] (fn [state] @@ -288,22 +351,13 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] -(defn |cons [head tail] - (V $Cons (T head tail))) - (defn |++ [xs ys] (|case xs ($Nil) ys ($Cons x xs*) - (V $Cons (T x (|++ xs* ys))))) - -(let [array-class (class (to-array []))] - (defn adt->text [adt] - (if (= array-class (class adt)) - (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") - (pr-str adt)))) + (Cons$ x (|++ xs* ys)))) (defn |map [f xs] (|case xs @@ -311,7 +365,7 @@ xs ($Cons x xs*) - (V $Cons (T (f x) (|map f xs*))) + (Cons$ (f x) (|map f xs*)) _ (assert false (prn-str '|map f (adt->text xs))) @@ -332,7 +386,7 @@ ($Cons x xs*) (if (p x) - (V $Cons (T x (|filter p xs*))) + (Cons$ x (|filter p xs*)) (|filter p xs*)))) (defn flat-map [f xs] @@ -346,13 +400,13 @@ (defn |split-with [p xs] (|case xs ($Nil) - (T xs xs) + (P xs xs) ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] - (T (|cons x pre) post)) - (T (V $Nil nil) xs)))) + (P (Cons$ x pre) post)) + (P Nil$ xs)))) (defn |contains? [k table] (|case table @@ -361,7 +415,10 @@ ($Cons [k* _] table*) (or (.equals ^Object k k*) - (|contains? k table*)))) + (|contains? k table*)) + + _ + (assert false (prn-str '|contains? k (adt->text table))))) (defn fold [f init xs] (|case xs @@ -386,15 +443,15 @@ (|list init) ($Cons x xs*) - (|cons init (folds f (f init x) xs*)))) + (Cons$ init (folds f (f init x) xs*)))) (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] (if (< from to) - (V $Cons (T from (|range* (inc from) to))) - (V $Nil nil)))] + (Cons$ from (|range* (inc from) to)) + Nil$))] (defn |range [n] (|range* 0 n))) @@ -409,10 +466,10 @@ (defn zip2 [xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (V $Cons (T (T x y) (zip2 xs* ys*))) + (Cons$ (P x y) (zip2 xs* ys*)) [_ _] - (V $Nil nil))) + Nil$)) (defn |keys [plist] (|case plist @@ -420,7 +477,7 @@ (|list) ($Cons [k v] plist*) - (|cons k (|keys plist*)))) + (Cons$ k (|keys plist*)))) (defn |vals [plist] (|case plist @@ -428,7 +485,7 @@ (|list) ($Cons [k v] plist*) - (|cons v (|vals plist*)))) + (Cons$ v (|vals plist*)))) (defn |interpose [sep xs] (|case xs @@ -439,7 +496,7 @@ xs ($Cons x xs*) - (V $Cons (T x (V $Cons (T sep (|interpose sep xs*))))))) + (Cons$ x (Cons$ sep (|interpose sep xs*))))) (do-template [<name> <joiner>] (defn <name> [f xs] @@ -452,23 +509,23 @@ ys (<name> f xs*)] (return (<joiner> y ys))))) - map% |cons + map% Cons$ flat-map% |++) (defn list-join [xss] - (fold |++ (V $Nil nil) xss)) + (fold |++ Nil$ xss)) (defn |as-pairs [xs] (|case xs ($Cons x ($Cons y xs*)) - (V $Cons (T (T x y) (|as-pairs xs*))) + (Cons$ (P x y) (|as-pairs xs*)) _ - (V $Nil nil))) + Nil$)) (defn |reverse [xs] (fold (fn [tail head] - (|cons head tail)) + (Cons$ head tail)) (|list) xs)) @@ -504,7 +561,7 @@ (defn repeat% [monad] (try-all% (|list (|do [head monad tail (repeat% monad)] - (return (|cons head tail))) + (return (Cons$ head tail))) (return (|list))))) (defn exhaust% [step] @@ -551,28 +608,28 @@ (def loader (fn [state] - (return* state (->> state (get$ $host) (get$ $loader))))) + (return* state (->> state $get-host ($get-loader))))) (def classes (fn [state] - (return* state (->> state (get$ $host) (get$ $classes))))) + (return* state (->> state $get-host ($get-classes))))) (def +init-bindings+ - (T ;; "lux;counter" + (P ;; "lux;counter" 0 ;; "lux;mappings" (|table))) (defn env [name] - (T ;; "lux;name" - name - ;; "lux;inner-closures" - 0 - ;; "lux;locals" - +init-bindings+ - ;; "lux;closure" - +init-bindings+ - )) + ($$ P ;; "lux;name" + name + ;; "lux;inner-closures" + 0 + ;; "lux;locals" + +init-bindings+ + ;; "lux;closure" + +init-bindings+ + )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String (class (byte-array [])) @@ -594,41 +651,41 @@ (defn host [_] (let [store (atom {})] - (T ;; "lux;writer" - (V $None nil) - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store))) + ($$ P ;; "lux;writer" + None$ + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store))) (defn init-state [_] - (T ;; "lux;source" - (V $None nil) - ;; "lux;cursor" - (T "" -1 -1) - ;; "lux;modules" - (|table) - ;; "lux;envs" - (|list) - ;; "lux;types" - +init-bindings+ - ;; "lux;expected" - (V $VariantT (|list)) - ;; "lux;seed" - 0 - ;; "lux;eval?" - false - ;; "lux;host" - (host nil) - )) + ($$ P ;; "lux;source" + None$ + ;; "lux;cursor" + ($$ P "" -1 -1) + ;; "lux;modules" + (|table) + ;; "lux;envs" + (|list) + ;; "lux;types" + +init-bindings+ + ;; "lux;expected" + (S $VoidT nil) + ;; "lux;seed" + 0 + ;; "lux;eval?" + false + ;; "lux;host" + (host nil) + )) (defn save-module [body] (fn [state] (|case (body state) ($Right state* output) (return* (->> state* - (set$ $envs (get$ $envs state)) - (set$ $source (get$ $source state))) + ($set-envs ($get-envs state)) + ($set-source ($get-source state))) output) ($Left msg) @@ -636,20 +693,20 @@ (defn with-eval [body] (fn [state] - (|case (body (set$ $eval? true state)) + (|case (body ($set-eval? true state)) ($Right state* output) - (return* (set$ $eval? (get$ $eval? state) state*) output) + (return* ($set-eval? ($get-eval? state) state*) output) ($Left msg) (fail* msg)))) (def get-eval (fn [state] - (return* state (get$ $eval? state)))) + (return* state ($get-eval? state)))) (def get-writer (fn [state] - (let [writer* (->> state (get$ $host) (get$ $writer))] + (let [writer* (->> state ($get-host) ($get-writer))] (|case writer* ($Some datum) (return* state datum) @@ -659,15 +716,15 @@ (def get-top-local-env (fn [state] - (try (let [top (|head (get$ $envs state))] + (try (let [top (|head ($get-envs state))] (return* state top)) (catch Throwable _ (fail* "No local environment."))))) (def gen-id (fn [state] - (let [seed (get$ $seed state)] - (return* (set$ $seed (inc seed) state) seed)))) + (let [seed ($get-seed state)] + (return* ($set-seed (inc seed) state) seed)))) (defn ->seq [xs] (|case xs @@ -680,26 +737,26 @@ (defn ->list [seq] (if (empty? seq) (|list) - (|cons (first seq) (->list (rest seq))))) + (Cons$ (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) - (|cons x (|repeat (dec n) x)) + (Cons$ x (|repeat (dec n) x)) (|list))) (def get-module-name (fn [state] - (|case (|reverse (get$ $envs state)) + (|case (|reverse ($get-envs state)) ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") ($Cons ?global _) - (return* state (get$ $name ?global))))) + (return* state ($get-name ?global))))) (defn find-module [name] "(-> Text (Lux (Module Compiler)))" (fn [state] - (if-let [module (|get name (get$ $modules state))] + (if-let [module (|get name ($get-modules state))] (return* state module) (fail* (str "Unknown module: " name))))) @@ -710,10 +767,10 @@ (defn with-scope [name body] (fn [state] - (let [output (body (update$ $envs #(|cons (env name) %) state))] + (let [output (body ($update-envs #(Cons$ (env name) %) state))] (|case output ($Right state* datum) - (return* (update$ $envs |tail state*) datum) + (return* ($update-envs |tail state*) datum) _ output)))) @@ -723,23 +780,24 @@ (defn with-closure [body] (|do [closure-name (|do [top get-top-local-env] - (return (->> top (get$ $inner-closures) str)))] + (return (->> top ($get-inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) - (|tail %)) - state)))))) + (run-state body* ($update-envs #(Cons$ ($update-inner-closures inc (|head %)) + (|tail %)) + state)))))) (def get-scope-name (fn [state] - (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse)))) + (return* state (->> state ($get-envs) (|map #($get-name %)) |reverse)))) (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] + (prn 'with-writer writer body) + (let [output (body ($update-host #($set-writer (Some$ writer) %) state))] (|case output ($Right ?state ?value) - (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) + (return* ($update-host #($set-writer (->> state ($get-host) ($get-writer)) %) ?state) ?value) _ @@ -748,10 +806,11 @@ (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] - (let [output (body (set$ $expected type state))] + ;; (prn 'with-expected-type type state) + (let [output (body ($set-expected type state))] (|case output ($Right ?state ?value) - (return* (set$ $expected (get$ $expected state) ?state) + (return* ($set-expected ($get-expected state) ?state) ?value) _ @@ -759,14 +818,20 @@ (defn with-cursor [^objects cursor body] "(All [a] (-> Cursor (Lux a)))" + ;; (prn 'with-cursor/_0 (adt->text cursor)) (if (= "" (aget cursor 0)) body (fn [state] - (let [output (body (set$ $cursor cursor state))] + (let [;; _ (prn 'with-cursor/_1 cursor) + state* ($set-cursor cursor state) + ;; _ (prn 'with-cursor/_2 state*) + output (body state*)] (|case output ($Right ?state ?value) - (return* (set$ $cursor (get$ $cursor state) ?state) - ?value) + (let [?state* ($set-cursor ($get-cursor state) ?state)] + ;; (prn 'with-cursor/_3 ?state*) + (return* ?state* + ?value)) _ output))))) @@ -774,40 +839,40 @@ (defn show-ast [ast] ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast - ($Meta _ ($BoolS ?value)) + [_ ($BoolS ?value)] (pr-str ?value) - ($Meta _ ($IntS ?value)) + [_ ($IntS ?value)] (pr-str ?value) - ($Meta _ ($RealS ?value)) + [_ ($RealS ?value)] (pr-str ?value) - ($Meta _ ($CharS ?value)) + [_ ($CharS ?value)] (pr-str ?value) - ($Meta _ ($TextS ?value)) + [_ ($TextS ?value)] (str "\"" ?value "\"") - ($Meta _ ($TagS ?module ?tag)) + [_ ($TagS ?module ?tag)] (str "#" ?module ";" ?tag) - ($Meta _ ($SymbolS ?module ?ident)) + [_ ($SymbolS ?module ?ident)] (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - ($Meta _ ($TupleS ?elems)) + [_ ($TupleS ?elems)] (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - ($Meta _ ($RecordS ?elems)) + [_ ($RecordS ?elems)] (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - ($Meta _ ($FormS ?elems)) + [_ ($FormS ?elems)] (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") _ @@ -835,10 +900,10 @@ [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] - (return (|cons z zs))) + (return (Cons$ z zs))) [($Nil) ($Nil)] - (return (V $Nil nil)) + (return Nil$) [_ _] (fail "Lists don't match in size."))) @@ -846,10 +911,10 @@ (defn map2 [f xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (|cons (f x y) (map2 f xs* ys*)) + (Cons$ (f x y) (map2 f xs* ys*)) [_ _] - (V $Nil nil))) + Nil$)) (defn fold2 [f init xs ys] (|case [xs ys] @@ -867,8 +932,8 @@ "(All [a] (-> Int (List a) (List (, Int a))))" (|case xs ($Cons x xs*) - (V $Cons (T (T idx x) - (enumerate* (inc idx) xs*))) + (Cons$ (P idx x) + (enumerate* (inc idx) xs*)) ($Nil) xs @@ -881,7 +946,7 @@ (def modules "(Lux (List Text))" (fn [state] - (return* state (|keys (get$ $modules state))))) + (return* state (|keys ($get-modules state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" @@ -895,23 +960,23 @@ (|case xs ($Cons x xs*) (cond (< idx 0) - (V $None nil) + None$ (= idx 0) - (V $Some x) + (Some$ x) :else ;; > 1 (|at (dec idx) xs*)) ($Nil) - (V $None nil) + None$ )) (defn normalize [ident] "(-> Ident (Lux Ident))" (|case ident ["" name] (|do [module get-module-name] - (return (T module name))) + (return (P module name))) _ (return ident))) (defn ident= [x y] @@ -923,12 +988,24 @@ (defn |list-put [idx val xs] (|case xs ($Nil) - (V $None nil) + None$ ($Cons x xs*) (if (= idx 0) - (V $Some (V $Cons (T val xs*))) + (Some$ (Cons$ val xs*)) (|case (|list-put (dec idx) val xs*) - ($None) (V $None nil) - ($Some xs**) (V $Some (V $Cons (T x xs**)))) + ($None) None$ + ($Some xs**) (Some$ (Cons$ x xs**))) ))) + +(defn ensure-1 [m-value] + (|do [output m-value] + (|case output + ($Cons x ($Nil)) + (return x) + + _ + (fail "[Error] Can't expand to other than 1 element.")))) + +(defn cursor$ [file-name line-num column-num] + ($$ P file-name line-num column-num)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 79d2c84f8..4315ea75d 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -39,8 +39,12 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] + ;; (prn 'compile-expression (&/adt->text syntax)) (|let [[?form ?type] syntax] (|case ?form + (&a/$unit) + (&&lux/compile-unit compile-expression ?type) + (&a/$bool ?value) (&&lux/compile-bool compile-expression ?type ?value) @@ -56,8 +60,11 @@ (&a/$text ?value) (&&lux/compile-text compile-expression ?type ?value) - (&a/$tuple ?elems) - (&&lux/compile-tuple compile-expression ?type ?elems) + (&a/$prod left right) + (&&lux/compile-prod compile-expression ?type left right) + + (&a/$sum tag value) + (&&lux/compile-sum compile-expression ?type tag value) (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) @@ -71,9 +78,6 @@ (&a/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) - (&a/$variant ?tag ?members) - (&&lux/compile-variant compile-expression ?type ?tag ?members) - (&a/$case ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) @@ -424,7 +428,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/set$ &/$source (&reader/from file-name file-content) state)) + (&/$set-source (&reader/from file-name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports @@ -471,7 +475,7 @@ ;; [Resources] (defn compile-program [program-module] (init!) - (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) + (|case ((&/map% compile-module (&/|list &/prelude-name program-module)) (&/init-state nil)) (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 1e5f3a024..72d569ed1 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -76,26 +76,32 @@ _ (load-class! loader real-name)]] (return nil))) -(do-template [<name> <class> <sig> <dup>] +(do-template [<name> <class> <sig>] (defn <name> [^MethodVisitor writer] (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str <sig> (&host/->type-signature <class>)))) - ;; (doto writer - ;; ;; X - ;; (.visitTypeInsn Opcodes/NEW <class>) ;; XW - ;; (.visitInsn <dup>) ;; WXW - ;; (.visitInsn <dup>) ;; WWXW - ;; (.visitInsn Opcodes/POP) ;; WWX - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>) ;; W - ;; ) - ) + (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str <sig> (&host/->type-signature <class>))))) - wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 - wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 - wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 - wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 - wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 - wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 - wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 - wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 + wrap-boolean "java/lang/Boolean" "(Z)" + wrap-byte "java/lang/Byte" "(B)" + wrap-short "java/lang/Short" "(S)" + wrap-int "java/lang/Integer" "(I)" + wrap-long "java/lang/Long" "(J)" + wrap-float "java/lang/Float" "(F)" + wrap-double "java/lang/Double" "(D)" + wrap-char "java/lang/Character" "(C)" + ) + +(do-template [<name> <class> <sig> <method>] + (defn <name> [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <method> (str "()" <sig>)))) + + unwrap-boolean "java/lang/Boolean" "Z" "booleanValue" + unwrap-byte "java/lang/Byte" "B" "byteValue" + unwrap-short "java/lang/Short" "S" "shortValue" + unwrap-int "java/lang/Integer" "I" "intValue" + unwrap-long "java/lang/Long" "J" "longValue" + unwrap-float "java/lang/Float" "F" "floatValue" + unwrap-double "java/lang/Double" "D" "doubleValue" + unwrap-char "java/lang/Character" "C" "charValue" ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index dc224f52e..48b35c83a 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -58,7 +58,7 @@ (defn clean [state] "(-> Compiler (,))" - (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) + (let [needed-modules (->> state (&/$get-modules) &/|keys &/->seq set) outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) program-file (new File &&/output-package)] @@ -120,7 +120,7 @@ ;; (prn '_group _group) (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] ;; (prn '[_type _tags] [_type _tags]) - (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + (&/P _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) @@ -132,10 +132,10 @@ (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) + (&a-module/define module _name (&/S &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] + (|do [_ (&a-module/define module _name (&/S &/$ValueD (&/P &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index dd3258059..b30fcb4f8 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -11,7 +11,7 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] + (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -84,63 +84,62 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$TupleTestAC ?members) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (-> (doto (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)) - (.visitInsn Opcodes/AALOAD) - (compile-match test $next $sub-else) - (.visitLabel $sub-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $next)) - (->> (|let [[idx test] idx+member - $next (new Label) - $sub-else (new Label)]) - (doseq [idx+member (->> ?members &/enumerate &/->seq)]))) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) + (&a-case/$ProdTestAC left right) + (let [$post-left (new Label) + $post-right (new Label)] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (compile-match left $post-left $else) + (.visitLabel $post-left) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (compile-match right $post-right $else) + (.visitLabel $post-right) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target))) - (&a-case/$VariantTestAC ?tag ?count ?test) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitLdcInsn ?tag) - (&&/wrap-long) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFEQ $else) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (-> (doto (compile-match ?test $value-then $value-else) - (.visitLabel $value-then) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $value-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else)) - (->> (let [$value-then (new Label) - $value-else (new Label)])))) + (&a-case/$SumTestAC ?tag ?count ?test) + (let [$value-then (new Label) + $sum-else (new Label)] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (&&/unwrap-int) + (.visitLdcInsn (int ?tag)) + (.visitJumpInsn Opcodes/IF_ICMPNE $sum-else) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (compile-match ?test $value-then $sum-else) + (.visitLabel $value-then) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target) + (.visitLabel $sum-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else))) ))) (defn ^:private separate-bodies [patterns] (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body] (|let [[$id mappings =matches] $id+mappings+=matches [pattern body] pattern+body] - (&/T (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) - (&/T 0 (&/|table) (&/|table)) + ($$ &/P (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) + ($$ &/P 0 (&/|table) (&/|table)) patterns)] - (&/T mappings (&/|reverse patterns*)))) + (&/P mappings (&/|reverse patterns*)))) (defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end] (let [entries (&/|map (fn [?branch+?body] (|let [[?branch ?body] ?branch+?body label (new Label)] - (&/T (&/T ?branch label) - (&/T label ?body)))) + (&/P (&/P ?branch label) + (&/P label ?body)))) mappings) mappings* (&/|map &/|first entries)] (doto writer diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 26ef73cb7..ead44085a 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,7 +52,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - (&/$TupleT (&/$Nil)) + (&/$UnitT) (.visitInsn *writer* Opcodes/ACONST_NULL) (&/$DataT "boolean") @@ -421,14 +421,14 @@ $catch-finally (new Label) compile-finally (|case ?finally (&/$Some ?finally*) (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -455,12 +455,12 @@ :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 83e294c1a..79383acc0 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -28,27 +28,43 @@ ClassWriter MethodVisitor))) +;; [Utils] +(defn ^:private array-of [^MethodVisitor *writer* type-name size] + (do (doto *writer* + (.visitLdcInsn (int size)) + (.visitTypeInsn Opcodes/ANEWARRAY type-name)) + (return nil))) + +(defn ^:private store-at [^MethodVisitor *writer* compile idx value] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + _ (compile value) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + ;; [Exports] +(defn compile-unit [compile *type*] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] + (return nil))) + (defn compile-bool [compile *type* ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) -(do-template [<name> <class> <sig> <caster>] +(do-template [<name> <wrapper>] (defn <name> [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (try (doto *writer* - (.visitTypeInsn Opcodes/NEW <class>) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (<caster> value)) - (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>)) - (catch Exception e - (assert false (prn-str '<name> (alength value) (aget value 0) (aget value 1)))))]] + :let [_ (doto *writer* + (.visitLdcInsn value) + (<wrapper>))]] (return nil))) - compile-int "java/lang/Long" "(J)V" long - compile-real "java/lang/Double" "(D)V" double - compile-char "java/lang/Character" "(C)V" char + compile-int &&/wrap-long + compile-real &&/wrap-double + compile-char &&/wrap-char ) (defn compile-text [compile *type* ?value] @@ -56,37 +72,28 @@ :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) -(defn compile-tuple [compile *type* ?elems] +(defn compile-prod [compile *type* left right] + ;; (prn 'compile-prod (&type/show-type *type*) + ;; (&/adt->text left) + ;; (&/adt->text right)) (|do [^MethodVisitor *writer* &/get-writer - :let [num-elems (&/|length ?elems) - _ (doto *writer* - (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - _ (&/map2% (fn [idx elem] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret))) - (&/|range num-elems) ?elems)] + _ (array-of *writer* "java/lang/Object" 2) + _ (store-at *writer* compile 0 left) + ;; :let [_ (prn 'compile-prod (&type/show-type *type*) left right)] + _ (store-at *writer* compile 1 right)] (return nil))) -(defn compile-variant [compile *type* ?tag ?value] +(defn compile-sum [compile *type* ?tag ?value] ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer + _ (array-of *writer* "java/lang/Object" 2) :let [_ (doto *writer* - (.visitLdcInsn (int 2)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) - (.visitLdcInsn ?tag) - (&&/wrap-long) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)))] - _ (compile ?value) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (.visitLdcInsn (int ?tag)) + (&&/wrap-int) + (.visitInsn Opcodes/AASTORE))] + _ (store-at *writer* compile 1 ?value)] (return nil))) (defn compile-local [compile *type* ?idx] diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj index db73e8bb4..50d8b0011 100644 --- a/src/lux/compiler/module.clj +++ b/src/lux/compiler/module.clj @@ -23,6 +23,6 @@ (return (&/|map (fn [pair] (|case pair [name [tags _]] - (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) - (&/get$ &module/$types module))) + (&/P name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&module/$get-types module))) )) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 7e2bc6961..cfaa9668b 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -9,83 +9,86 @@ (ns lux.compiler.type (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] + (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] [type :as &type]) [lux.analyser.base :as &a])) ;; [Utils] -(defn ^:private variant$ [tag body] - "(-> Text Analysis Analysis)" - (&/T (&/V &a/$variant (&/T tag body)) +(def ^:private unit$ + "Analysis" + (&/P (&/S &a/$unit nil) + &type/$Void)) + +(defn ^:private sum$ [tag body] + "(-> Int Analysis Analysis)" + (&/P (&/S &a/$sum (&/P tag body)) &type/$Void)) -(defn ^:private tuple$ [members] - "(-> (List Analysis) Analysis)" - (&/T (&/V &a/$tuple members) +(defn ^:private prod$ [left right] + "(-> Analysis Analysis Analysis)" + (&/P (&/S &a/$prod (&/P left right)) &type/$Void)) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/T (&/V &a/$text text) + (&/P (&/S &a/$text text) &type/$Void)) (def ^:private $Nil "Analysis" - (variant$ &/$Nil (tuple$ (&/|list)))) + (sum$ &/$Nil unit$)) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" - (variant$ &/$Cons (tuple$ (&/|list head tail)))) + (sum$ &/$Cons (prod$ head tail))) ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" (|case type (&/$DataT ?class) - (variant$ &/$DataT (text$ ?class)) + (sum$ &/$DataT (text$ ?class)) - (&/$TupleT ?members) - (variant$ &/$TupleT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) + (&/$ProdT left right) + (sum$ &/$ProdT + (prod$ (->analysis left) + (->analysis right))) - (&/$VariantT ?members) - (variant$ &/$VariantT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) + (&/$SumT left right) + (sum$ &/$SumT + (prod$ (->analysis left) + (->analysis right))) (&/$LambdaT ?input ?output) - (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) + (sum$ &/$LambdaT (prod$ (->analysis ?input) (->analysis ?output))) (&/$AllT ?env ?name ?arg ?body) - (variant$ &/$AllT - (tuple$ (&/|list (|case ?env - (&/$None) - (variant$ &/$None (tuple$ (&/|list))) + (sum$ &/$AllT + ($$ prod$ + (|case ?env + (&/$None) + (sum$ &/$None unit$) - (&/$Some ??env) - (variant$ &/$Some - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) - $Nil - (&/|reverse ??env)))) - (text$ ?name) - (text$ ?arg) - (->analysis ?body)))) + (&/$Some ??env) + (sum$ &/$Some + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (prod$ (text$ hlabel) + (->analysis htype)) + tail))) + $Nil + (&/|reverse ??env)))) + (text$ ?name) + (text$ ?arg) + (->analysis ?body))) (&/$BoundT ?name) - (variant$ &/$BoundT (text$ ?name)) + (sum$ &/$BoundT (text$ ?name)) (&/$AppT ?fun ?arg) - (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + (sum$ &/$AppT (prod$ (->analysis ?fun) (->analysis ?arg))) (&/$NamedT [?module ?name] ?type) - (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) - (->analysis ?type)))) + (sum$ &/$NamedT (prod$ (prod$ (text$ ?module) (text$ ?name)) + (->analysis ?type))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index dfd4df23d..d77e9b31c 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,8 +29,8 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base))) + (return (&/S &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + base))) ))) (defn ^:private method->type [^Method method] @@ -76,7 +76,7 @@ (&/$LambdaT _ _) (->type-signature function-class) - (&/$TupleT (&/$Nil)) + (&/$VoidT) "V" (&/$NamedT ?name ?type) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index e848cc3fd..91693cc77 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -13,22 +13,22 @@ [lux.analyser.module :as &module])) ;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" +(deftags + ["White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace"] ) ;; [Utils] @@ -58,19 +58,19 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/V &/$Meta (&/T meta (&/V $White_Space white-space)))))) + (return (&/P meta (&/S $White_Space white-space))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) + (return (&/P meta (&/S $Comment comment))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") ;; :let [_ (prn 'immediate comment)] _ (&reader/read-text ")#")] - (return (&/T meta comment))) + (return (&/P meta comment))) (|do [;; :let [_ (prn 'pre/_0)] [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") ;; :let [_ (prn 'pre pre)] @@ -79,10 +79,10 @@ [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] ] - (return (&/T meta (str pre "#(" inner ")#" post)))))) + (return (&/P meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) + (return (&/P meta (&/S $Comment comment))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -91,7 +91,7 @@ (do-template [<name> <tag> <regex>] (def <name> (|do [[meta token] (&reader/read-regex <regex>)] - (return (&/V &/$Meta (&/T meta (&/V <tag> token)))))) + (return (&/P meta (&/S <tag> token))))) ^:private lex-bool $Bool #"^(true|false)" ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" @@ -105,13 +105,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V $Char token)))))) + (return (&/P meta (&/S $Char token))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V $Text token)))))) + (return (&/P meta (&/S $Text token))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -119,35 +119,35 @@ [_ local-token] (&reader/read-regex +ident-re+) ? (&module/exists? token)] (if ? - (return (&/T meta (&/T token local-token))) + (return (&/P meta (&/P token local-token))) (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) - (&module/dealias token))] + (&module/dealias token))] (do ;; (prn "Unaliased: " unaliased ";" local-token) - (return (&/T meta (&/T unaliased local-token))))))) - (return (&/T meta (&/T "" token))) + (return (&/P meta (&/P unaliased local-token))))))) + (return (&/P meta (&/P "" token))) ))) (|do [[meta _] (&reader/read-text ";;") [_ token] (&reader/read-regex +ident-re+) module-name &/get-module-name] - (return (&/T meta (&/T module-name token)))) + (return (&/P meta (&/P module-name token)))) (|do [[meta _] (&reader/read-text ";") [_ token] (&reader/read-regex +ident-re+)] - (return (&/T meta (&/T "lux" token)))) + (return (&/P meta (&/P &/prelude-name token)))) ))) (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V $Symbol ident)))))) + (return (&/P meta (&/S $Symbol ident))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V $Tag ident)))))) + (return (&/P meta (&/S $Tag ident))))) (do-template [<name> <text> <tag>] (def <name> (|do [[meta _] (&reader/read-text <text>)] - (return (&/V &/$Meta (&/T meta (&/V <tag> nil)))))) + (return (&/P meta (&/S <tag> nil))))) ^:private lex-open-paren "(" $Open_Paren ^:private lex-close-paren ")" $Close_Paren diff --git a/src/lux/parser.clj b/src/lux/parser.clj index eaa22db20..c40221d63 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -14,22 +14,22 @@ [lexer :as &lexer]))) ;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" +(deftags + ["White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace"] ) ;; [Utils] @@ -38,8 +38,8 @@ (|do [elems (&/repeat% parse) token &lexer/lex] (|case token - (&/$Meta meta [<close-token> _]) - (return (&/V <tag> (&/fold &/|++ (&/|list) elems))) + [meta [<close-token> _]] + (return (&/S <tag> (&/fold &/|++ (&/|list) elems))) _ (fail (str "[Parser Error] Unbalanced " <description> "."))))) @@ -53,9 +53,9 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - (&/$Meta meta ($Close_Brace _)) + [meta ($Close_Brace _)] (if (even? (&/|length elems)) - (return (&/V &/$RecordS (&/|as-pairs elems))) + (return (&/S &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) _ @@ -64,7 +64,7 @@ ;; [Interface] (def parse (|do [token &lexer/lex - :let [(&/$Meta meta token*) token]] + :let [[meta token*] token]] (|case token* ($White_Space _) (return (&/|list)) @@ -73,37 +73,37 @@ (return (&/|list)) ($Bool ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) + (return (&/|list (&/P meta (&/S &/$BoolS (Boolean/parseBoolean ?value))))) ($Int ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) + (return (&/|list (&/P meta (&/S &/$IntS (Long/parseLong ?value))))) ($Real ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) + (return (&/|list (&/P meta (&/S &/$RealS (Double/parseDouble ?value))))) ($Char ^String ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) + (return (&/|list (&/P meta (&/S &/$CharS (.charAt ?value 0))))) ($Text ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) + (return (&/|list (&/P meta (&/S &/$TextS ?value)))) ($Symbol ?ident) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) + (return (&/|list (&/P meta (&/S &/$SymbolS ?ident)))) ($Tag ?ident) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) + (return (&/|list (&/P meta (&/S &/$TagS ?ident)))) ($Open_Paren _) (|do [syntax (parse-form parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/P meta syntax)))) ($Open_Bracket _) (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/P meta syntax)))) ($Open_Brace _) (|do [syntax (parse-record parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/P meta syntax)))) _ (fail "[Parser Error] Unknown lexer token.") diff --git a/src/lux/reader.clj b/src/lux/reader.clj index e3f95b5f9..24a0bf94d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -10,18 +10,18 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) + [lux.base :as & :refer [deftags |do return* return fail fail* |let |case $$]])) ;; [Tags] -(deftags "" - "No" - "Done" - "Yes") +(deftags + ["No" + "Done" + "Yes"]) ;; [Utils] (defn ^:private with-line [body] (fn [state] - (|case (&/get$ &/$source state) + (|case (&/$get-source state) (&/$Nil) (fail* "[Reader Error] EOF") @@ -32,19 +32,19 @@ (fail* msg) ($Done output) - (return* (&/set$ &/$source more state) + (return* (&/$set-source more state) output) ($Yes output line*) - (return* (&/set$ &/$source (&/|cons line* more) state) + (return* (&/$set-source (&/Cons$ line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (|case (body (&/get$ &/$source state)) + (|case (body (&/$get-source state)) (&/$Right reader* match) - (return* (&/set$ &/$source reader* state) + (return* (&/$set-source reader* state) match) (&/$Left msg) @@ -85,10 +85,10 @@ match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T (&/T file-name line-num column-num) match)) - (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/S $Done (&/P (&/cursor$ file-name line-num column-num) match)) + (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) match) + (&/P (&/cursor$ file-name line-num column-num*) line))))) + (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line @@ -98,10 +98,10 @@ (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) - (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/S $Done (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2))) + (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2)) + (&/P (&/cursor$ file-name line-num column-num*) line))))) + (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] (with-lines @@ -110,7 +110,7 @@ reader* reader] (|case reader* (&/$Nil) - (&/V &/$Left "[Reader Error] EOF") + (&/S &/$Left "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] ^String line] reader**) @@ -120,10 +120,10 @@ column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) + (&/S &/$Right (&/P (&/Cons$ (&/P (&/cursor$ file-name line-num column-num*) line) reader**) - (&/T (&/T file-name line-num column-num) (str prefix match)))))) - (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) + (&/P (&/cursor$ file-name line-num column-num) (str prefix match)))))) + (&/S &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line @@ -133,10 +133,10 @@ (let [match-length (.length text) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T (&/T file-name line-num column-num) text)) - (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V $No (str "[Reader Error] Text failed: " text)))))) + (&/S $Done (&/P (&/cursor$ file-name line-num column-num) text)) + (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) text) + (&/P (&/cursor$ file-name line-num column-num*) line))))) + (&/S $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") (defn from [^String file-name ^String file-content] @@ -144,7 +144,7 @@ file-name (.substring file-name (.length +source-dir+))] (&/|map (fn [line+line-num] (|let [[line-num line] line+line-num] - (&/T (&/T file-name (inc line-num) 0) + (&/P (&/cursor$ file-name (inc line-num) 0) line))) (&/|filter (fn [line+line-num] (|let [[line-num line] line+line-num] diff --git a/src/lux/type.clj b/src/lux/type.clj index 9f3adb036..4193d8df4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -10,7 +10,7 @@ (:refer-clojure :exclude [deref apply merge bound?]) (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) + [lux.base :as & :refer [|do return* return fail fail* assert! |let |case $$]])) (declare show-type) @@ -26,302 +26,300 @@ _ false)) -(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) -(def ^:private no-env (&/V &/$None nil)) +(def ^:private empty-env (&/Some$ &/Nil$)) +(def ^:private no-env &/None$) +(def Ident$ &/P) (defn Data$ [name] - (&/V &/$DataT name)) + (&/S &/$DataT name)) (defn Bound$ [name] - (&/V &/$BoundT name)) + (&/S &/$BoundT name)) (defn Var$ [id] - (&/V &/$VarT id)) + (&/S &/$VarT id)) (defn Lambda$ [in out] - (&/V &/$LambdaT (&/T in out))) + (&/S &/$LambdaT (&/P in out))) (defn App$ [fun arg] - (&/V &/$AppT (&/T fun arg))) -(defn Tuple$ [members] + (&/S &/$AppT (&/P fun arg))) +(defn Prod$ [left right] ;; (assert (|list? members)) - (&/V &/$TupleT members)) -(defn Variant$ [members] + (&/S &/$ProdT (&/P left right))) +(defn Sum$ [left right] ;; (assert (|list? members)) - (&/V &/$VariantT members)) + (&/S &/$SumT (&/P left right))) (defn All$ [env name arg body] - (&/V &/$AllT (&/T env name arg body))) + (&/S &/$AllT ($$ &/P env name arg body))) (defn Named$ [name type] - (&/V &/$NamedT (&/T name type))) + (&/S &/$NamedT (&/P name type))) - -(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean"))) -(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long"))) -(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double"))) -(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character"))) -(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String"))) -(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list)))) -(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list)))) -(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) +(def Bool (Named$ (Ident$ &/prelude-name "Bool") (Data$ "java.lang.Boolean"))) +(def Int (Named$ (Ident$ &/prelude-name "Int") (Data$ "java.lang.Long"))) +(def Real (Named$ (Ident$ &/prelude-name "Real") (Data$ "java.lang.Double"))) +(def Char (Named$ (Ident$ &/prelude-name "Char") (Data$ "java.lang.Character"))) +(def Text (Named$ (Ident$ &/prelude-name "Text") (Data$ "java.lang.String"))) +(def Unit (Named$ (Ident$ &/prelude-name "Unit") (&/S &/$UnitT nil))) +(def $Void (Named$ (Ident$ &/prelude-name "Void") (&/S &/$VoidT nil))) +(def Ident (Named$ (Ident$ &/prelude-name "Ident") (Prod$ Text Text))) (def IO - (Named$ (&/T "lux/data" "IO") + (Named$ (Ident$ "lux/data" "IO") (All$ empty-env "IO" "a" (Lambda$ Unit (Bound$ "a"))))) (def List - (Named$ (&/T "lux" "List") + (Named$ (Ident$ &/prelude-name "List") (All$ empty-env "lux;List" "a" - (Variant$ (&/|list - ;; lux;Nil - Unit - ;; lux;Cons - (Tuple$ (&/|list (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a")))) - ))))) + (Sum$ + ;; lux;Nil + Unit + ;; lux;Cons + (Prod$ (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a"))) + )))) (def Maybe - (Named$ (&/T "lux" "Maybe") + (Named$ (Ident$ &/prelude-name "Maybe") (All$ empty-env "lux;Maybe" "a" - (Variant$ (&/|list - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - ))))) + (Sum$ + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + )))) (def Type - (Named$ (&/T "lux" "Type") + (Named$ (Ident$ &/prelude-name "Type") (let [Type (App$ (Bound$ "Type") (Bound$ "_")) TypeList (App$ List Type) - TypeEnv (App$ List (Tuple$ (&/|list Text Type))) - TypePair (Tuple$ (&/|list Type Type))] + TypeEnv (App$ List (Prod$ Text Type)) + TypePair (Prod$ Type Type)] (App$ (All$ empty-env "Type" "_" - (Variant$ (&/|list - ;; DataT - Text - ;; VariantT - TypeList - ;; TupleT - TypeList - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) - ;; AppT - TypePair - ;; NamedT - (Tuple$ (&/|list Ident Type)) - ))) + ($$ Sum$ + ;; VoidT + Unit + ;; UnitT + Unit + ;; SumT + TypePair + ;; ProdT + TypePair + ;; DataT + Text + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + ($$ Prod$ (App$ Maybe TypeEnv) Text Text Type) + ;; AppT + TypePair + ;; NamedT + (Prod$ Ident Type) + )) $Void)))) (def Bindings - (Named$ (&/T "lux" "Bindings") + (Named$ (Ident$ &/prelude-name "Bindings") (All$ empty-env "lux;Bindings" "k" (All$ no-env "" "v" - (Tuple$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ "k") - (Bound$ "v")))))))))) + (Prod$ + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Prod$ (Bound$ "k") + (Bound$ "v")))))))) (def Env - (Named$ (&/T "lux" "Env") + (Named$ (Ident$ &/prelude-name "Env") (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] (All$ empty-env "lux;Env" "k" (All$ no-env "" "v" - (Tuple$ - (&/|list - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - ))))))) + ($$ Prod$ + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + )))))) (def Cursor - (Named$ (&/T "lux" "Cursor") - (Tuple$ (&/|list Text Int Int)))) + (Named$ (Ident$ &/prelude-name "Cursor") + ($$ Prod$ Text Int Int))) (def Meta - (Named$ (&/T "lux" "Meta") + (Named$ (Ident$ &/prelude-name "Meta") (All$ empty-env "lux;Meta" "m" (All$ no-env "" "v" - (Variant$ (&/|list - ;; &/$Meta - (Tuple$ (&/|list (Bound$ "m") - (Bound$ "v"))))))))) + (Prod$ (Bound$ "m") + (Bound$ "v")))))) (def AST* - (Named$ (&/T "lux" "AST'") + (Named$ (Ident$ &/prelude-name "AST'") (let [AST* (App$ (Bound$ "w") (App$ (Bound$ "lux;AST'") (Bound$ "w"))) AST*List (App$ List AST*)] (All$ empty-env "lux;AST'" "w" - (Variant$ (&/|list - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Tuple$ (&/|list AST* AST*)))) - ))))) + ($$ Sum$ + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Prod$ AST* AST*)) + ))))) (def AST - (Named$ (&/T "lux" "AST") + (Named$ (Ident$ &/prelude-name "AST") (let [w (App$ Meta Cursor)] (App$ w (App$ AST* w))))) (def ^:private ASTList (App$ List AST)) (def Either - (Named$ (&/T "lux" "Either") + (Named$ (Ident$ &/prelude-name "Either") (All$ empty-env "lux;Either" "l" (All$ no-env "" "r" - (Variant$ (&/|list - ;; &/$Left - (Bound$ "l") - ;; &/$Right - (Bound$ "r"))))))) + (Sum$ + ;; &/$Left + (Bound$ "l") + ;; &/$Right + (Bound$ "r")))))) (def StateE (All$ empty-env "lux;StateE" "s" (All$ no-env "" "a" (Lambda$ (Bound$ "s") (App$ (App$ Either Text) - (Tuple$ (&/|list (Bound$ "s") - (Bound$ "a")))))))) + (Prod$ (Bound$ "s") + (Bound$ "a"))))))) (def Source - (Named$ (&/T "lux" "Source") + (Named$ (Ident$ &/prelude-name "Source") (App$ List (App$ (App$ Meta Cursor) Text)))) (def Host - (Named$ (&/T "lux" "Host") - (Tuple$ - (&/|list - ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter") - ;; "lux;loader" - (Data$ "java.lang.ClassLoader") - ;; "lux;classes" - (Data$ "clojure.lang.Atom"))))) + (Named$ (Ident$ &/prelude-name "Host") + ($$ Prod$ + ;; "lux;writer" + (Data$ "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (Data$ "java.lang.ClassLoader") + ;; "lux;classes" + (Data$ "clojure.lang.Atom")))) (def DefData* (All$ empty-env "lux;DefData'" "" - (Variant$ (&/|list - ;; "lux;ValueD" - (Tuple$ (&/|list Type Unit)) - ;; "lux;TypeD" - Type - ;; "lux;MacroD" - (Bound$ "") - ;; "lux;AliasD" - Ident - )))) + ($$ Sum$ + ;; "lux;ValueD" + (Prod$ Type Unit) + ;; "lux;TypeD" + Type + ;; "lux;MacroD" + (Bound$ "") + ;; "lux;AliasD" + Ident + ))) (def LuxVar - (Named$ (&/T "lux" "LuxVar") - (Variant$ (&/|list - ;; "lux;Local" - Int - ;; "lux;Global" - Ident)))) + (Named$ (Ident$ &/prelude-name "LuxVar") + (Sum$ + ;; "lux;Local" + Int + ;; "lux;Global" + Ident))) (def $Module (All$ empty-env "lux;$Module" "Compiler" - (Tuple$ - (&/|list - ;; "lux;module-aliases" - (App$ List (Tuple$ (&/|list Text Text))) - ;; "lux;defs" - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ "Compiler")) - ASTList)))))))) - ;; "lux;imports" - (App$ List Text) - ;; "lux;tags" - ;; (List (, Text (, Int (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Int - (App$ List Ident) - Type))))) - ;; "lux;types" - ;; (List (, Text (, (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list (App$ List Ident) - Type))))) - )))) + ($$ Prod$ + ;; "lux;module-aliases" + (App$ List (Prod$ Text Text)) + ;; "lux;defs" + (App$ List + (Prod$ Text + (Prod$ Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ "Compiler")) + ASTList)))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (, Int (List Ident) Type))) + (App$ List + (Prod$ Text + ($$ Prod$ Int + (App$ List Ident) + Type))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Prod$ Text + (Prod$ (App$ List Ident) + Type))) + ))) (def $Compiler - (Named$ (&/T "lux" "Compiler") + (Named$ (Ident$ &/prelude-name "Compiler") (App$ (All$ empty-env "lux;Compiler" "" - (Tuple$ - (&/|list - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Tuple$ (&/|list LuxVar Type)))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - ))) + ($$ Prod$ + ;; "lux;source" + Source + ;; "lux;cursor" + Cursor + ;; "lux;modules" + (App$ List (Prod$ Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Prod$ LuxVar Type))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;expected" + Type + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;host" + Host + )) $Void))) (def Macro - (Named$ (&/T "lux" "Macro") + (Named$ (Ident$ &/prelude-name "Macro") (Lambda$ ASTList (App$ (App$ StateE $Compiler) ASTList)))) (defn bound? [id] (fn [state] - (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (if-let [type (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -332,7 +330,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (if-let [type* (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -343,32 +341,37 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (if-let [tvar (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) - ts)) - state) + (return* (&/$update-type-vars (fn [ts] (&/$update-mappings #(&/|put id (&/Some$ type) %) + ts)) + state) nil)) - (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/$get-type-vars) (&/$get-mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] - (return* (&/update$ &/$type-vars #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) - state) + (let [id (->> state &/$get-type-vars &/$get-counter)] + (return* (&/$update-type-vars #(do ;; (prn 'create-var/_0 (&/adt->text %)) + ;; (prn 'create-var/_1 (&/adt->text (->> % (&/$update-counter inc)))) + ;; (prn 'create-var/_2 (&/adt->text (->> % + ;; (&/$update-counter inc) + ;; (&/$update-mappings (fn [ms] (&/|put id &/None$ ms)))))) + (->> % + (&/$update-counter inc) + (&/$update-mappings (fn [ms] (&/|put id &/None$ ms))))) + state) id)))) (def existential (|do [seed &/gen-id] - (return (&/V &/$ExT seed)))) + (return (&/S &/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -390,19 +393,19 @@ (|case ?type* (&/$VarT ?id*) (if (.equals ^Object id ?id*) - (return (&/T ?id (&/V &/$None nil))) + (return (&/P ?id &/None$)) (return binding)) _ (|do [?type** (clean* id ?type*)] - (return (&/T ?id (&/V &/$Some ?type**))))) + (return (&/P ?id (&/Some$ ?type**))))) )))) - (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] + (->> state (&/$get-type-vars) (&/$get-mappings)))] (fn [state] - (return* (&/update$ &/$type-vars #(->> % - (&/update$ &/$counter dec) - (&/set$ &/$mappings (&/|remove id mappings*))) - state) + (return* (&/$update-type-vars #(->> % + (&/$update-counter dec) + (&/$set-mappings (&/|remove id mappings*))) + state) nil))) state)))) @@ -435,13 +438,15 @@ =param (clean* ?tid ?param)] (return (App$ =lambda =param))) - (&/$TupleT ?members) - (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (Tuple$ =members))) - - (&/$VariantT ?members) - (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (Variant$ =members))) + (&/$SumT ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (Sum$ =left =right))) + + (&/$ProdT ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (Prod$ =left =right))) (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env @@ -451,9 +456,9 @@ (&/$Some ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) + (return (&/P k =v)))) ?env*)] - (return (&/V &/$Some clean-env)))) + (return (&/Some$ clean-env)))) body* (clean* ?tid ?body)] (return (All$ =env ?name ?arg body*))) @@ -473,37 +478,36 @@ (|case type (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] - (&/T ??out (&/|cons ?in ?args))) + (&/P ??out (&/Cons$ ?in ?args))) _ - (&/T type (&/|list)))) + (&/P type (&/|list)))) (defn ^:private unravel-app [fun-type] (|case fun-type (&/$AppT ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] - (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) + (&/P ?fun-type (&/|++ ?args (&/|list ?right)))) _ - (&/T fun-type (&/|list)))) + (&/P fun-type (&/|list)))) (defn show-type [^objects type] (|case type + (&/$VoidT) + "(|)" + + (&/$UnitT) + "(,)" + (&/$DataT name) (str "(^ " name ")") - (&/$TupleT elems) - (if (&/|empty? elems) - "(,)" - (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - - (&/$VariantT cases) - (if (&/|empty? cases) - "(|)" - (str "(| " (->> cases - (&/|map show-type) - (&/|interpose " ") - (&/fold str "")) ")")) + (&/$ProdT left right) + (str "(, " (show-type left) " " (show-type right) ")") + + (&/$SumT left right) + (str "(| " (show-type left) " " (show-type right) ")") (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] @@ -547,15 +551,13 @@ [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) - [(&/$TupleT xelems) (&/$TupleT yelems)] - (&/fold2 (fn [old x y] (and old (type= x y))) - true - xelems yelems) + [(&/$ProdT xleft xright) (&/$ProdT yleft yright)] + (and (type= xleft yleft) + (type= xright yright)) - [(&/$VariantT xcases) (&/$VariantT ycases)] - (&/fold2 (fn [old x y] (and old (type= x y))) - true - xcases ycases) + [(&/$SumT xleft xright) (&/$SumT yleft yright)] + (and (type= xleft yleft) + (type= xright yright)) [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) @@ -607,17 +609,17 @@ (|let [[e a] k] (|case fixpoints (&/$Nil) - (&/V &/$None nil) + &/None$ (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) - (&/V &/$Some v*) + (&/Some$ v*) (fp-get k fixpoints*)) ))) (defn ^:private fp-put [k v fixpoints] - (&/|cons (&/T k v) fixpoints)) + (&/Cons$ (&/P k v) fixpoints)) (defn ^:private check-error [expected actual] (str "[Type Checker]\nExpected: " (show-type expected) @@ -626,11 +628,11 @@ (defn beta-reduce [env type] (|case type - (&/$VariantT ?members) - (Variant$ (&/|map (partial beta-reduce env) ?members)) + (&/$SumT ?left ?right) + (Sum$ (beta-reduce env ?left) (beta-reduce env ?right)) - (&/$TupleT ?members) - (Tuple$ (&/|map (partial beta-reduce env) ?members)) + (&/$ProdT ?left ?right) + (Prod$ (beta-reduce env ?left) (beta-reduce env ?right)) (&/$AppT ?type-fn ?type-arg) (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) @@ -638,7 +640,7 @@ (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def) + (All$ (&/Some$ env) ?local-name ?local-arg ?local-def) (&/$Some _) type) @@ -697,30 +699,32 @@ (def ^:private init-fixpoints (&/|list)) (defn ^:private check* [class-loader fixpoints expected actual] + ;; (prn 'check*/_0 (&/adt->text expected) (&/adt->text actual)) + ;; (prn 'check*/_1 (show-type expected) (show-type actual)) (if (clojure.lang.Util/identical expected actual) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (|case [expected actual] [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (|do [ebound (fn [state] (|case ((deref ?eid) state) (&/$Right state* ebound) - (return* state* (&/V &/$Some ebound)) + (return* state* (&/Some$ ebound)) (&/$Left _) - (return* state (&/V &/$None nil)))) + (return* state &/None$))) abound (fn [state] (|case ((deref ?aid) state) (&/$Right state* abound) - (return* state* (&/V &/$Some abound)) + (return* state* (&/Some$ abound)) (&/$Left _) - (return* state (&/V &/$None nil))))] + (return* state &/None$)))] (|case [ebound abound] [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] - (return (&/T fixpoints nil))) + (return (&/P fixpoints nil))) [(&/$Some etype) (&/$None _)] (check* class-loader fixpoints etype actual) @@ -735,7 +739,7 @@ (fn [state] (|case ((set-var ?id actual) state) (&/$Right state* _) - (return* state* (&/T fixpoints nil)) + (return* state* (&/P fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -746,7 +750,7 @@ (fn [state] (|case ((set-var ?id expected) state) (&/$Right state* _) - (return* state* (&/T fixpoints nil)) + (return* state* (&/P fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -757,9 +761,9 @@ (fn [state] (|case ((|do [F1 (deref ?eid)] (fn [state] - (|case [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) - state)] + (|case ((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + state) (&/$Right state* output) (return* state* output) @@ -780,11 +784,11 @@ (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] - (return (&/T fixpoints** nil))) + (return (&/P fixpoints** nil))) state)))) ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] - ;; (return (&/T fixpoints nil))) + ;; (return (&/P fixpoints nil))) [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] @@ -799,14 +803,14 @@ e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/T fixpoints** nil))) + (return (&/P fixpoints** nil))) state))) ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) + ;; (return (&/P fixpoints** nil))) [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] @@ -821,17 +825,17 @@ e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/T fixpoints** nil))) + (return (&/P fixpoints** nil))) state))) ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) + ;; (return (&/P fixpoints** nil))) [(&/$AppT F A) _] - (let [fp-pair (&/T expected actual) + (let [fp-pair (&/P expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) (&/|map (fn [pair] @@ -844,7 +848,7 @@ (|case (fp-get fp-pair fixpoints) (&/$Some ?) (if ? - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (fail (check-error expected actual))) (&/$None) @@ -870,39 +874,33 @@ [(&/$DataT e!name) (&/$DataT "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) - (return (&/T fixpoints nil))) + (return (&/P fixpoints nil))) [(&/$DataT e!name) (&/$DataT a!name)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] (if (or (.equals ^Object e!name a!name) (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [(&/$TupleT e!members) (&/$TupleT a!members)] - (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] - (return fp*))) - fixpoints - e!members a!members)] - (return (&/T fixpoints* nil))) + [(&/$ProdT e!left e!right) (&/$ProdT a!left a!right)] + (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) + [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] + (return (&/P fixpoints** nil))) - [(&/$VariantT e!cases) (&/$VariantT a!cases)] - (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] - (return fp*))) - fixpoints - e!cases a!cases)] - (return (&/T fixpoints* nil))) + [(&/$SumT e!left e!right) (&/$SumT a!left a!right)] + (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) + [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] + (return (&/P fixpoints** nil))) [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (fail (check-error expected actual))) [(&/$NamedT ?ename ?etype) _] @@ -958,20 +956,31 @@ )) (defn variant-case [tag type] + ;; (prn 'variant-case tag (show-type type)) (|case type (&/$NamedT ?name ?type) (variant-case tag ?type) - (&/$VariantT ?cases) - (|case (&/|at tag ?cases) - (&/$Some case-type) - (return case-type) + (&/$SumT ?left ?right) + (case tag + 0 + (return ?left) - (&/$None) - (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type)))) + 1 + (|case ?right + (&/$SumT ?left* _) + (return ?left*) + + _ + (return ?right)) + + ;; else + (variant-case (dec tag) ?right)) _ - (fail (str "[Type Error] Type is not a variant: " (show-type type))))) + (fail (str "[Type Error] Type is not a variant: " (show-type type))) + ;; (assert false (str "[Type Error] Type is not a variant: " (show-type type))) + )) (defn type-name [type] "(-> Type (Lux Ident))" |